Только что получено Ошибка времени выполнения '6' Переполнение впервые в Access Db, который работал без ошибок более года. Ничего не изменилось в коде или данных. Я не могу понять, почему это внезапно появилось. Это создание электронной почты. Может кто-нибудь помочь?
Ниже приведен мой код, где происходит ошибка:
enter code here
Public Sub proc_AutomateEmail_EVerify()
On Error GoTo Err_MakeEmail_EV
Dim dbs As Database
Dim rsEMails As Recordset
Dim rsEE As Recordset
Dim objOutlook As Outlook.Application
Dim objEmail As Outlook.MailItem
Dim sHTML_Email As String
Dim sHTMLHead As String
Dim sHTMLClose As String
Dim sTableOpen As String
Dim sTableClose As String
Dim sTableExtra As String
Dim sLetterOpen As String
Dim sLetterClose As String
Dim sLetterClose2 As String
Dim sTableBody As String
Dim sAddresses As String
Dim sCC As String
Dim sPath As String
Dim sFile As String
Dim sAttach As String
Dim sBase As String
Dim sAsOf As String
Dim sPathAttach As String
Dim theEmailID As Integer
Dim theEMailQuery As String
Dim theHistQuery As String
Dim theEMailStatus As String
Dim theEmailCrit As String
Dim sqlEE As String
'Change status box to yellow and create initial message
Forms!frm_Email_Parts_Process!txtShowStatus.BackColor = RGB(255, 255, 200)
Forms!frm_Email_Parts_Process!txtShowStatus = "Creating Emails for the following person(Sector):"
Set dbs = CurrentDb
Set objOutlook = CreateObject("Outlook.Application")
'HTML Code to open and close the email - this has nothing to do with email content
sHTMLHead = DLookup("[ConfigVal]", "admin_Config_Memo", "ConfigVar='Email_Automate_Reverify_Head_01'")
sHTMLClose = DLookup("[ConfigVal]", "admin_Config_Memo", "ConfigVar='Email_Automate_Reverify_Close_01'")
sTableExtra = ""
sPathAttach = DLookup("[ConfigVal]", "Admin_Config", "[ConfigVar] = 'AttachmentPath'")
theEmailID = Nz(Forms!frm_Email_Parts_Process!lstPickEmail, 0)
theEmailCrit = "EMPartsID = " & theEmailID
Debug.Print "theEMailCrit: " & theEmailCrit
theEMailQuery = DLookup("[EMPartsQuery]", "data_EMail_Parts", theEmailCrit)
theHistQuery = DLookup("[EMPartsQuery_App]", "data_EMail_Parts", theEmailCrit)
theEMailStatus = DLookup("[EMPartsDisplayStatus]", "data_EMail_Parts", theEmailCrit)
Debug.Print "theEMailQuery: " & theEMailQuery
'Open and closing content and Subject line of the email
sLetterOpen = DLookup("[EMPartsIntro]", "data_EMail_Parts", "[EMPartsID] = " & theEmailID)
sLetterClose = DLookup("[EMPartsClose]", "data_EMail_Parts", "[EMPartsID] = " & theEmailID)
sLetterClose2 = DLookup("[EMPartsClose2]", "data_EMail_Parts", "[EMPartsID] = " & theEmailID)
sSubject = DLookup("[EMPartsSubject]", "data_EMail_Parts", "[EMPartsID] = " & theEmailID)
sAttach = DLookup("[EMPartsAttach]", "data_EMail_Parts", "[EMPartsID] = " & theEmailID)
'Table headers for the list of employees
sTableOpen = "<br /><br /><table>"
sTableClose = "</table><br /><br />"
'If theEmailID = 12 Then ' need extra 'table' for end of email
'
' sTableExtra = "<table id='closereason'>"
' sTableExtra = sTableExtra & "<tr class='theheader'><td>Employment Status</td><td>Authorized E-Verify Case Closure Reason</td></tr>"
'
' sTableExtra = sTableExtra & "<tr><td>Active</td><td>The employee continues to work after receiving an Employment Authorized result.</td></tr>"
' sTableExtra = sTableExtra & "<tr><td>Employee Resignation</td><td>The employee voluntarily quit working for the employer.</td></tr>"
' sTableExtra = sTableExtra & "<tr><td>Termination UNRELATED to E-Verify Process</td><td>The employee was terminated by the employer for reasons other than E-Verify.</td></tr>"
' sTableExtra = sTableExtra & "<tr><td rowspan='3'>Termination Related to E-Verify Process</td><td>The employee was terminated by the employer for receiving a No Show result.</td></tr>"
' sTableExtra = sTableExtra & "<tr><td>The employee was terminated by the employer for receiving a Final Nonconfirmation.</td></tr>"
' sTableExtra = sTableExtra & "<tr><td>The employee was terminated by the employer for choosing NOT to contest a Tentative Nonconfirmation.</td></tr>"
'
' sTableExtra = sTableExtra & "</table>"
'
'End If
'Get list of people for emailing - try without fully anotated : email_automate_Reverify_I9Expire_prior_90.
' for testing: SELECT Top 5
sqlPeople = "SELECT [Emp Custom_ChiefEmail_Replace], " & _
"[Business Unit], " & _
"Count([Employee ID]) AS [CountIt] " & _
"FROM " & theEMailQuery & " " & _
"GROUP BY [Emp Custom_ChiefEmail_Replace], " & _
"[Business Unit] " & _
"HAVING ((([Emp Custom_ChiefEmail_Replace]) Is Not Null));"
Set rsEMails = dbs.OpenRecordset(sqlPeople)
If rsEMails.RecordCount > 0 Then
rsEMails.MoveLast
rsEMails.MoveFirst
'Loop through people
Do Until rsEMails.EOF
Debug.Print "CHIEF: " & rsEMails![Emp Custom_ChiefEmail_Replace]
Forms!frm_Email_Parts_Process!txtShowStatus = rsEMails![Emp Custom_ChiefEmail_Replace] & vbCr & vbLf & Forms!frm_Email_Parts_Process!txtShowStatus
'Detail listing of people for the email
sTableBody = "<tr><td class = 'colhead_loc'>Location</td>" & _
"<td class = 'colhead_eename'>Employee Name</td>" & _
"<td class = 'colhead_eeid'>Employee ID</td>" & _
"<td class = 'colhead_eeid'>Date Hired</td>" & _
"<td class = 'colhead_eename'>E-Verify Status</td></tr>"
sTableBody = sTableBody & "<tr class='trblankrow'><td colspan='5'></td></tr>"
'List Employees Section - FULL NAME : email_automate_Reverify_I9Expire_prior_90.
sqlEE = "SELECT [Business Unit], " & _
"[Location Number], " & _
"[Location Name], " & _
"[Employee Name], " & _
"[Employee ID], " & _
"[Date Hired], " & _
"[EV Current Status] " & _
"From " & theEMailQuery & " " & _
"WHERE ((([Emp Custom_ChiefEmail_Replace])=" & Chr(34) & rsEMails![Emp Custom_ChiefEmail_Replace] & Chr(34) & "));"
Set rsEE = dbs.OpenRecordset(sqlEE)
If rsEE.RecordCount > 0 Then
rsEE.MoveLast
rsEE.MoveFirst
'Loop through people
Do Until rsEE.EOF
Debug.Print "EE: " & rsEE![Employee Name]
sTableBody = sTableBody & "<tr class='trplain'><td class='td_txt_left'>" & rsEE![Location Name] & " (" & rsEE![Location Number] & ")</td>" & _
"<td class='td_txt_left'>" & rsEE![Employee Name] & "</td>" & _
"<td class='td_txt_ctr'>" & rsEE![Employee ID] & "</td>" & _
"<td class='td_txt_ctr'>" & rsEE![Date Hired] & "</td>" & _
"<td class='td_txt_ctr'>" & theEMailStatus & "</td></tr>"
rsEE.MoveNext
Loop 'rsEe
rsEE.Close
Else ' No email addresses
sTableBody = sTableBody & "<tr><td colspan='4' class = 'tblhead1boldit'>No Employees for this Chief</td></tr>"
End If
'Get email addresses
sAddresses = rsEMails![Emp Custom_ChiefEmail_Replace]
'sCC = DLookup("BUN_Email_CC", "[data_BusinessUnit]", sCritAddresses)
'Create the email
sHTML_Email = sHTMLHead & sLetterOpen & sTableOpen & sTableBody & sTableClose & sLetterClose & sLetterClose2 & sHTMLClose
'Debug.Print sHTML_Email
Set objEmail = objOutlook.CreateItem(olMailItem)
With objEmail
.To = sAddresses
'.CC = sCC
.Subject = sSubject
If sAttach <> "none" Then
.Attachments.Add sPathAttach & sAttach
End If
.BodyFormat = olFormatHTML
.HTMLBody = sHTML_Email
.Save
End With
Set objEmail = Nothing
rsEMails.MoveNext
Loop 'rsEMails
rsEMails.Close
Else ' No email addresses
End If
dbs.Close
'Update status indicator - Adding names to history list
Forms!frm_Email_Parts_Process!txtShowStatus = "-------------------------------" & vbCr & vbLf & Forms!frm_Email_Parts_Process!txtShowStatus
Forms!frm_Email_Parts_Process!txtShowStatus = "Adding names to history list" & vbCr & vbLf & Forms!frm_Email_Parts_Process!txtShowStatus
Forms!frm_Email_Parts_Process!txtShowStatus = "-------------------------------" & vbCr & vbLf & Forms!frm_Email_Parts_Process!txtShowStatus
DoCmd.SetWarnings False
DoCmd.OpenQuery theHistQuery
DoCmd.SetWarnings True
'Update status indicator - Set back color to green
Forms!frm_Email_Parts_Process!txtShowStatus.BackColor = RGB(200, 255, 200)
Forms!frm_Email_Parts_Process!txtShowStatus = "-- Process complete --" & vbCr & vbLf & Forms!frm_Email_Parts_Process!txtShowStatus
Exit_MakeEmail_EV:
Exit Sub
Err_MakeEmail_EV:
DoCmd.SetWarnings True
Select Case Err.Number
Case 6 ' Overflow due to 0 in data
Call LogError(Err.Number, Err.Description, "Sector: " & sCurrentSector)
Resume Next ' Use this to just ignore the line.
Case 94 ' Overflow due to 0 in data
Call LogError(Err.Number, Err.Description, "Sector: " & sCurrentSector)
Resume Next ' Use this to just ignore the line.
Case 3075 ' Apostrophe Error ???
Call LogError(Err.Number, rsEMails![Business Unit], "Apostrophe Error")
Resume Next ' Use this to just ignore the line.
Case 3420 ' Overflow due to 0 in data
Call LogError(Err.Number, "Error Log Error", "Unknown")
Resume Next ' Use this to just ignore the line.
Case 999
Resume Exit_MakeEmail_EV ' Use this to give up on the proc.
Case Else ' Any unexpected error.
Call LogError(Err.Number, Err.Description, "Sector: " & sCurrentSector)
Resume Exit_MakeEmail_EV
End Select
End Sub