I get an intermittent error when looping through the Outlook inbox using VBA. A type mismatch occurs on the Next objOutlookMesg line.
Note: I wanted to be as thourough as possible so I included all the code. Scroll to the bottom for an abreviated snip of where the error occurs.
Private Sub CheckInbox(strFolder As String, Title As String)
Dim objOutlook As Outlook.Application
Dim objOutlookNS As Outlook.Namespace
Dim objOutlookInbox As Outlook.Folder
Dim objOutlookComp As Outlook.Folder
Dim objOutlookMesg As Outlook.MailItem
Dim Headers(1 To 20) As String
Dim i As Integer
Headers(1) = "Division:"
Headers(2) = "Request:"
Headers(3) = "Exception Type:"
Headers(4) = "Owning Branch:"
Headers(5) = "CRM Opportunity#:"
Headers(6) = "Account Type:"
Headers(7) = "Created Date:"
Headers(8) = "Close Date:"
Headers(9) = "Created By:"
Headers(10) = "Account Number:"
Headers(11) = "Revenue Amount:"
Headers(12) = "Total Deposit Reported:"
Headers(13) = "Actual Total Deposits Received:"
Headers(14) = "Deposit Date:"
Headers(15) = "Deposit Source:"
Headers(16) = "Explanation:"
Headers(17) = "Shared Credit Branch:"
Headers(18) = "Shared Credit: Amount to Transfer:"
Headers(19) = "OptionsFirst: Deposit Date:"
Headers(20) = "OptionsFirst: Total Deposit:"
Set objOutlook = Outlook.Application
Set objOutlookNS = objOutlook.GetNamespace("MAPI")
Set objOutlookInbox = objOutlookNS.GetDefaultFolder(olFolderInbox)
Set objOutlookComp = objOutlookInbox.Folders(strFolder)
For Each objOutlookMesg In objOutlookInbox.Items
objOutlookMesg.Display
If Trim(objOutlookMesg.Subject) Like Title Then
For i = 1 To 20
WriteToExcel i, EmailTextExtraction(Headers(i), objOutlookMesg), 1
Next i
objOutlookMesg.Move objOutlookComp
End If
Next objOutlookMesg
End Sub
Private Sub WriteToExcel(CollumnNDX As Integer, Data As String, WorksheetNDX As Integer)
'Writes data to first empty cell on the specified collumn in the specified workbook
Dim RowNDX As Long
Do
RowNDX = RowNDX + 1
Loop Until Worksheets(WorksheetNDX).Cells(RowNDX, CollumnNDX) = Empty
Worksheets(WorksheetNDX).Cells(RowNDX, CollumnNDX).Value = Data
End Sub
Private Function EmailTextExtraction(Field As String, Message As Outlook.MailItem) As String
'Obtains the data in a field of a text formatted email when the data
'in that field immediately follows the field and is immediately followed
'by a carriage return.
Dim Position1 As Long
Dim Position2 As Long
Dim Data As String
Dim FieldLength As Integer
FieldLength = Len(Field)
Position1 = InStr(1, Message.Body, Field, vbTextCompare) + FieldLength
Position2 = InStr(Position1, Message.Body, Chr(10), vbTextCompare)
'may need to use CHAR(13) depending on the carriage return
Data = Trim(Mid(Message.Body, Position1, Position2 - Position1))
EmailTextExtraction = Data
End Function
Shorter snip of the code where the error occurs:
For Each objOutlookMesg In objOutlookInbox.Items
objOutlookMesg.Display
If Trim(objOutlookMesg.Subject) Like Title Then
For i = 1 To 20
WriteToExcel i, EmailTextExtraction(Headers(i), objOutlookMesg), 1
Next i
objOutlookMesg.Move objOutlookComp
End If
Next objOutlookMesg <<<< intermitent type mismatch error here
I think the error may have to do with the class of the mailitems. Looking to filter for that now.
An outlook folder has a default object type (MailItem, AppointmentItem, ContactItem, etc) but can actually hold any item type. So you're hitting an item that's not a MailItem and, by virtue of a For Each loop, trying to assign it to a variable that is a MailItem type.
You need to loop through with a generic Object and test the TypeName.
Dim oItem As Object
Dim oMail As MailItem
For Each oItem In Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Items
If TypeName(oItem) = "MailItem" Then
Set oMail = oItem
'do stuff with omail
End If
Next oItem
If you love us? You can donate to us via Paypal or buy me a coffee so we can maintain and grow! Thank you!
Donate Us With