Почему внезапная ошибка во время выполнения «6» переполнение - доступ к VBA? - PullRequest
2 голосов
/ 18 февраля 2020

Только что получено Ошибка времени выполнения '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

1 Ответ

2 голосов
/ 18 февраля 2020

Ничего не изменилось в коде или данных.

То есть данные остались прежними? Я сомневаюсь, что.

Возможно, вы исчерпали целочисленные значения. Так что попробуйте:

Dim theEmailID As Long
Добро пожаловать на сайт PullRequest, где вы можете задавать вопросы и получать ответы от других членов сообщества.
...