types不匹配循环扫描Outlook邮件

使用VBA循环播放Outlook收件箱时，会出现间歇性错误。 types不匹配发生在Next objOutlookMes​​g行上。

注意：我希望尽可能使所有代码都包含在内。 滚动到底部，查看出现错误的位置。

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 

发生错误的代码片段较短：

 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 

我认为这个错误可能与邮件类的类有关。 想要过滤现在。

Answer 1

一个Outlook文件夹有一个默认的对象types（MailItem，AppointmentItem，ContactItem等），但实际上可以包含任何项目types。 所以，你正在打一个不是MailItem的项目，并且凭借For Each循环，试图将它分配给一个MailItemtypes的variables。

您需要循环访问一个通用对象并testingTypeName。

 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