Type Mismatch in Loop to scan Outlook messages

Question

I get an intermittent error when going through an Outlook mailbox using VBA. Type mismatch occurs on the next line of objOutlookMesg.

Note. I wanted to be as large as possible, so I included all the code. Scroll down to the paragraph below 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 

A shorter piece of code in which 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 be related to the mail item class. Now you want to filter it.

Answer 1

The Outlook folder has an object type by default (MailItem, AppointmentItem, ContactItem, etc.), but can actually contain any type of element. Thus, you click on an item that is not MailItem, and by For For loop it tries to assign it to a variable of type MailItem.

You need to go through the shared object and check 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