Why Does MailItem.ReceivedTime Error on the Second Pass?

Question

I'm using VBA to go through my Inbox, log the e-mail addresses that got bounced back, and then delete the e-mail. This code seemed to work until it encountered an undeliverable that didn't have an e-mail address. After I thought I accounted for this, the next e-mail, which happens to also be undeliverable, throws a run-time error 438.

Also, after removing the entirely, the loop jumps 7 e-mails ahead and never changes the indeces of the greater than and less than symbols. Does anyone know why the date error occurs on the loop after an undeliverable with no e-mail address, and why the code can't seem to find the next occurring indeces?

Dim SinceDate As Date
SinceDate = Range("L1").Value2
Range("B1").Select
If Range("B2").Value2 <> "" Then
    Selection.End(xlDown).Select
End If
ActiveCell.Offset(1, 0).Select

Dim outOutlook As Object
Set outOutlook = CreateObject("Outlook.Application")
Dim outNamespace As Object
Dim myInbox As Object
Dim outItems As Object
Dim outItem As Object

Set outNamespace = outOutlook.GetNamespace("MAPI")
Set myInbox = outNamespace.Folders("myemail@myemail.com").Folders("Inbox")

Set outItems = myInbox.Items

'Retrieve the Undeliverable E-Mail Subjects
Dim intFirst As Integer         'Location of first '<'
Dim intLast As Integer          'Location of first '>' after '<'
Dim strBody As String           'Will hold Body Text of Undeliverable E-Mail
Dim strUndlvr                   'Holds the actual Undeliverable E-Mail Address
Dim emailTime As Date
Dim emailSubject As String

For Each outItem In outItems    'All Items in the Inbox
    emailTime = CDate(outItem.receivedTime) 'ERROR THROWN HERE!!!
    emailSubject = outItem.Subject
    If emailTime >= SinceDate And (InStr(outItem.Subject, "failure notice") > 0 Or InStr(outItem.Subject, "Undeliverable:") > 0 Or InStr(outItem.Subject, "Delivery Status Notification (Failure)") > 0 Or InStr(outItem.Subject, "Returned mail:") > 0) Then
        strBody = outItem.Body      'Body of Undeliverable E-Mail
        If InStr(strBody, "Your message to ") > 0 And InStr(strBody, " couldn't be delivered") > 0 Then
            intFirst = InStr(strBody, "Your message to ") + 15
            intLast = InStr(strBody, " couldn't be delivered")
        ElseIf InStr(strBody, "Your message to ") > 0 And InStr(strBody, " has been blocked.") > 0 Then
            intFirst = InStr(strBody, "Your message to ") + 15
            intLast = InStr(strBody, " has been blocked.")
        Else
            intFirst = InStr(strBody, "<")
            intLast = InStr(intFirst + 1, strBody, ">")
        End If
        If intFirst <> 0 And intLast <> 0 Then
            strUndlvr = Mid$(strBody, (intFirst + 1), (intLast - intFirst) - 1)     'E-Mail Address
            strUndlvr = Replace(strUndlvr, " ", "")
            strUndlvr = Replace(strUndlvr, "mailto:", "")
            If strUndlvr <> "" Then
                ActiveCell.Value2 = strUndlvr
                ActiveCell.Offset(1, 0).Select
                outItem.Display
                outItem.Delete
            End If                
        End If
    End If
Next

Set outOutlook = Nothing
Set outNamespace = Nothing
Set outItem = Nothing

EDIT: Big thanks to the two comments! It turns out the problem was a combination of 1) using a For Each loop with Outlook, and 2) Some undeliverable mail being a ReportItem instead of a MailItem. The solution was to iterate backwards through outlook using a regular For loop and counter, plus coding for ReportItem extensions as well as MailItem. I'm sure there's a more efficient way to do it, but the working loop is below. Thanks again!

Dim i As Long

For i = outItems.Count To 1 Step -1         'All Items in the Inbox
    Set outItem = outItems(i)
    If TypeName(outItem) = "MailItem" Then
        emailTime = CDate(outItem.receivedTime)
        emailSubject = outItem.Subject
        If emailTime >= SinceDate And (InStr(emailSubject, "failure notice") > 0 Or InStr(emailSubject, "Undeliverable:") > 0 Or InStr(emailSubject, "Delivery Status Notification (Failure)") > 0 Or InStr(emailSubject, "Returned mail:") > 0) Then
            strBody = outItem.Body      'Body of Undeliverable E-Mail
            If InStr(strBody, "Your message to ") > 0 And InStr(strBody, " couldn't be delivered") > 0 Then
                intFirst = InStr(strBody, "Your message to ") + 15
                intLast = InStr(strBody, " couldn't be delivered")
                BadEmail = True
            ElseIf InStr(strBody, "Your message to ") > 0 And InStr(strBody, " has been blocked.") > 0 Then
                intFirst = InStr(strBody, "Your message to ") + 15
                intLast = InStr(strBody, " has been blocked.")
                BadEmail = True
            ElseIf InStr(strBody, "The following recipient(s) cannot be reached:") > 0 Then
                intFirst = InStr(strBody, "The following recipient(s) cannot be reached:") + 44
                intLast = InStr(strBody, " on ")
                BadEmail = True
            ElseIf InStr(strBody, "Your message wasn't delivered to ") > 0 And InStr(strBody, " because the address couldn't be found") > 0 Then
                intFirst = InStr(strBody, "Your message wasn't delivered to ") + 32
                intLast = InStr(strBody, " because the address couldn't be found")
                BadEmail = True
            ElseIf InStr(strBody, "<") > 0 And InStr(strBody, ">") > 0 Then
                intFirst = InStr(strBody, "<")
                intLast = InStr(intFirst + 1, strBody, ">")
                BadEmail = True
            End If
            If BadEmail = True Then
                strUndlvr = Mid$(strBody, (intFirst + 1), (intLast - intFirst) - 1)     'E-Mail Address
                strUndlvr = Replace(strUndlvr, " ", "")
                strUndlvr = Replace(strUndlvr, "mailto:", "")
                strUndlvr = Replace(strUndlvr, "'", "")
                strUndlvr = Replace$(Trim$(strUndlvr), vbTab, "")
                If strUndlvr <> "" Then
                    ActiveCell.Value2 = strUndlvr
                    ActiveCell.Offset(1, 0).Select
                    outItem.Display
                    outItem.Delete
                End If
            End If
            BadEmail = False
        ElseIf emailTime < SinceDate Then
            Exit For
        End If
    Else 'ReportItem
        emailTime = CDate(outItem.CreationTime)
        emailSubject = outItem.Subject
        If emailTime >= SinceDate And (InStr(emailSubject, "failure notice") > 0 Or InStr(emailSubject, "Undeliverable:") > 0 Or InStr(emailSubject, "Delivery Status Notification (Failure)") > 0 Or InStr(emailSubject, "Returned mail:") > 0) Then
            strBody = outItem.Body      'Body of Undeliverable E-Mail
            If InStr(strBody, "Your message to ") > 0 And InStr(strBody, " couldn't be delivered") > 0 Then
                intFirst = InStr(strBody, "Your message to ") + 15
                intLast = InStr(strBody, " couldn't be delivered")
                BadEmail = True
            ElseIf InStr(strBody, "Your message to ") > 0 And InStr(strBody, " has been blocked.") > 0 Then
                intFirst = InStr(strBody, "Your message to ") + 15
                intLast = InStr(strBody, " has been blocked.")
                BadEmail = True
            ElseIf InStr(strBody, "The following recipient(s) cannot be reached:") > 0 Then
                intFirst = InStr(strBody, "The following recipient(s) cannot be reached:") + 44
                intLast = InStr(strBody, " on ")
                BadEmail = True
            ElseIf InStr(strBody, "Your message wasn't delivered to ") > 0 And InStr(strBody, " because the address couldn't be found") > 0 Then
                intFirst = InStr(strBody, "Your message wasn't delivered to ") + 32
                intLast = InStr(strBody, " because the address couldn't be found")
                BadEmail = True
            ElseIf InStr(strBody, "<") > 0 And InStr(strBody, ">") > 0 Then
                intFirst = InStr(strBody, "<")
                intLast = InStr(intFirst + 1, strBody, ">")
                BadEmail = True
            End If
            If BadEmail = True Then
                strUndlvr = Mid$(strBody, (intFirst + 1), (intLast - intFirst) - 1)     'E-Mail Address
                strUndlvr = Replace(strUndlvr, " ", "")
                strUndlvr = Replace(strUndlvr, "mailto:", "")
                strUndlvr = Replace(strUndlvr, "'", "")
                strUndlvr = Replace$(Trim$(strUndlvr), vbTab, "")
                If strUndlvr <> "" Then
                    ActiveCell.Value2 = strUndlvr
                    ActiveCell.Offset(1, 0).Select
                    outItem.Display
                    outItem.Delete
                End If
            End If
            BadEmail = False
        ElseIf emailTime < SinceDate Then
            Exit For
        End If
    End If
Next i

Not everything in your inbox is a mail item, so it's good practice to first filter to only the things you're interested in e.g. `If TypeOf outItem Is MailItem Then` — Tim Williams, Feb 09 '21 at 22:22
Possible duplicate of [For Each loop: Some items get skipped when looping through Outlook mailbox to delete items](https://stackoverflow.com/questions/10725068/for-each-loop-some-items-get-skipped-when-looping-through-outlook-mailbox-to-de) — niton, Feb 09 '21 at 22:53

Why Does MailItem.ReceivedTime Error on the Second Pass?

0 Answers0