Есть ли лучший способ для отслеживания жестких отскоков, кроме чтения сообщения электронной почты?

Question

Итак, у меня есть код, который работает, импортируя все электронные письма из моего почтового ящика.Затем я читаю текст письма с поиском ключевых слов, а затем помечает их как отклоненные.Есть ли лучший способ сделать это?

Я просматривал элементы данных электронной почты, конечно, там есть что-то, что можно использовать.

В настоящее время я всегда делал отскоки вручную, нотеперь я начал посылать еще несколько электронных писем, и это стало рутиной, чтобы не отставать.Поэтому я хотел написать кусок кода.

 Sub Download_Outlook_Mail_To_Access()
'Add Tools->References->"Microsoft Outlook nn.n Object Library"
'nn.n varies as per our Outlook Installation
Dim Folder As Outlook.MAPIFolder
Dim sFolders As Outlook.MAPIFolder
Dim iRow As Integer, oRow As Integer
Dim MailBoxName As String, Pst_Folder_Name  As String
Dim rs As DAO.Recordset

'Mailbox or PST Main Folder Name (As how it is displayed in your Outlook 
Session)
MailBoxName = "TEST"

'Mailbox Folder or PST Folder Name (As how it is displayed in your Outlook 
Session)
Pst_Folder_Name = "Inbox" 'Sample "Inbox" or "Sent Items"

'To directly a Folder at a high level
Set Folder = Outlook.Session.Folders(MailBoxName).Folders(Pst_Folder_Name)

'To access a main folder or a subfolder (level-1)
For Each Folder In Outlook.Session.Folders(MailBoxName).Folders
    If VBA.UCase(Folder.Name) = VBA.UCase(Pst_Folder_Name) Then GoTo 
Label_Folder_Found
    For Each sFolders In Folder.Folders
        If VBA.UCase(sFolders.Name) = VBA.UCase(Pst_Folder_Name) Then
            Set Folder = sFolders
            GoTo Label_Folder_Found
        End If
    Next sFolders
Next Folder

 Label_Folder_Found:
 If Folder.Name = "" Then
    MsgBox "Invalid Data in Input"
    GoTo End_Lbl1:
End If

'Read Through each Mail and export the details to Excel for Email Archival
Folder.Items.Sort "Received"
Set rs = CurrentDb.OpenRecordset("SELECT * FROM Table1;")
'Export eMail Data from PST Folder
oRow = 1
For iRow = 1 To Folder.Items.Count
    'If condition to import mails received in last 60 days
    'To import all emails, comment or remove this IF condition
    If VBA.DateValue(VBA.Now) - 
   VBA.DateValue(Folder.Items.Item(iRow).ReceivedTime) <= 7 Then
       oRow = oRow + 1
       rs.AddNew
       rs!SenderName = Folder.Items.Item(iRow).SenderName
       rs!Subject = Folder.Items.Item(iRow).Subject
       rs!ReceivedTime = Folder.Items.Item(iRow).ReceivedTime
       rs!Size = Folder.Items.Item(iRow).Size
       rs!SenderEmailAddress = Folder.Items.Item(iRow).SenderEmailAddress
       rs!Body = Folder.Items.Item(iRow).Body
       rs.Update
    End If
Next iRow

Set Folder = Nothing
Set sFolders = Nothing
rs.Close
Set rs = Nothing
Dim Body As String

Set rs = CurrentDb.OpenRecordset("SELECT ID, Body, Bounced FROM Table1;")
Do Until rs.EOF Or rs.BOF
rs.MoveFirst
    Body = rs!Body
    If checkEmail(Body) = True Then
        rs.Edit
        rs![Bounced] = True
        rs.Update
    End If
rs.MoveNext
Loop
rs.Close
Set rs = Nothing

End_Lbl1:
End Sub
Public Function checkEmail(ByVal Body As String) As Boolean
Dim keywords(30) As String
Dim word As Variant
keywords(0) = "Delivery to the following recipients failed"
keywords(1) = "user unknown"
keywords(2) = "The e-mail account does not exist"
keywords(3) = "undeliverable address"
keywords(4) = "550 Host unknown"
keywords(5) = "No such user"
keywords(6) = "Addressee unknown"
keywords(7) = "Mailaddress is administratively disabled"
keywords(8) = "unknown or invalid"
keywords(9) = "Recipient address rejected"
keywords(10) = "disabled or discontinued"
keywords(11) = "Recipient verification failed"
keywords(12) = "no mailbox here by that name"
keywords(13) = "This user doesn't have a yahoo.com account"
keywords(14) = "No mailbox found"
keywords(15) = "not our customer"
keywords(16) = "mailbox unavailable"
keywords(17) = "Mailbox disabled"
keywords(18) = "mailbox is inactive"
keywords(19) = "address error"
keywords(20) = "unknown recipient"
keywords(21) = "unknown user"
keywords(22) = "mail to the recipient is not accepted on this system"
keywords(23) = "no user with that name"
keywords(24) = "invalid recipient"
keywords(25) = "message could not be delivered"
keywords(26) = "Host or domain name not found"
keywords(27) = "Connection timed out"
keywords(28) = "The following recipient(s) could not be reached"
keywords(29) = "could not deliver"
keywords(30) = "Relay access denied"

'Default value
checkEmail = False
For Each word In keywords
If InStr(1, Body, word, vbTextCompare) > 1 Then
    checkEmail = True
    Exit For
End If
Next word
End Function