读取到CC和BCC属性时出错

我试图将所有的电子邮件提取到外部程序（AIMMS）。 我首先将其全部存储在Excel中以供阅读。

我写了一些VBA代码。 当多个电子邮件地址在此字段中时， .Tofunction不起作用（给出即时错误）。 .CC和.BCC也是如此。

Sub Extract_mail(MailBoxName As String, Pst_Folder_Name As String, Subfolder As String) 'Add Tools->References->"Microsoft Outlook nn.n Object Library" Dim folders As Outlook.folders Dim Folder As Outlook.MAPIFolder Dim iRow As Integer Dim objMItem As MailItem If Subfolder = "" Then Set Folder = Outlook.Session.folders(MailBoxName).folders(Pst_Folder_Name) Else Set Folder = Outlook.Session.folders(MailBoxName).folders(Pst_Folder_Name).folders(Subfolder) End If If Folder = "" Then MsgBox "Invalid Data in Input" GoTo end_lbl1: End If 'Rad Through each Mail and export the details to Excel for Email Archival ActiveWorkbook.Sheets("Sheet1").Cells.Clear ActiveWorkbook.Sheets("Sheet1").Cells(1, 1) = "ID" ActiveWorkbook.Sheets("Sheet1").Cells(1, 2) = "To" ActiveWorkbook.Sheets("Sheet1").Cells(1, 3) = "EmailAddress" ActiveWorkbook.Sheets("Sheet1").Cells(1, 4) = "Name" ActiveWorkbook.Sheets("Sheet1").Cells(1, 5) = "Subject" ActiveWorkbook.Sheets("Sheet1").Cells(1, 6) = "Date" ActiveWorkbook.Sheets("Sheet1").Cells(1, 7) = "Body" ActiveWorkbook.Sheets("Sheet1").Cells(1, 8) = "Size" For iRow = 1 To Folder.Items.Count ActiveWorkbook.Sheets("Sheet1").Cells(iRow + 1, 1).Select ActiveWorkbook.Sheets("Sheet1").Cells(iRow + 1, 1) = iRow ActiveWorkbook.Sheets("Sheet1").Cells(iRow + 1, 2) = Folder.Items.Item(iRow).To ActiveWorkbook.Sheets("Sheet1").Cells(iRow + 1, 3) = Folder.Items.Item(iRow).SenderEmailAddress ActiveWorkbook.Sheets("Sheet1").Cells(iRow + 1, 4) = Folder.Items.Item(iRow).SenderName ActiveWorkbook.Sheets("Sheet1").Cells(iRow + 1, 5) = Folder.Items.Item(iRow).Subject ActiveWorkbook.Sheets("Sheet1").Cells(iRow + 1, 6) = Folder.Items.Item(iRow).ReceivedTime ActiveWorkbook.Sheets("Sheet1").Cells(iRow + 1, 7) = Folder.Items.Item(iRow).Body ActiveWorkbook.Sheets("Sheet1").Cells(iRow + 1, 8) = Folder.Items.Item(iRow).Size Next iRow ActiveWorkbook.Save 'ActiveWorkbook.Close end_lbl1: End Sub 

Answer 1

这可能是您正在循环访问Outlook电子邮件文件夹的情况，但除此之外还有其他项目，比如“MeetingItem”。 有几个项目可以驻留在这样的文件夹中，没有.To属性。

所以，你需要一个简单的检查MailItems并从那里继续：

 Sub Extract_mail(MailBoxName As String, Pst_Folder_Name As String, Optional Subfolder As String) 'Dim oFolders As Outlook.Folders Dim oFolder As Outlook.MAPIFolder Dim iRow As Integer Dim olItem As Object If Subfolder = "" Then Set oFolder = Outlook.Session.Folders(MailBoxName).Folders(Pst_Folder_Name) Else Set oFolder = Outlook.Session.Folders(MailBoxName).Folders(Pst_Folder_Name).Folders(Subfolder) End If If oFolder.Name = "" Then MsgBox "Invalid Data in Input" Exit Sub End If iRow = 0 'Read Through each Mail and export the details to Excel for Email Archival With ActiveWorkbook.Worksheets("Sheet1") .Cells.Clear .Cells(1, 1) = "ID" .Cells(1, 2) = "To" .Cells(1, 3) = "EmailAddress" .Cells(1, 4) = "Name" .Cells(1, 5) = "Subject" .Cells(1, 6) = "Date" .Cells(1, 7) = "Body" .Cells(1, 8) = "Size" For Each olItem In oFolder.Items If TypeOf olItem Is Outlook.MailItem Then 'This is the important bit! .Cells(iRow + 2, 1) = iRow .Cells(iRow + 2, 2) = olItem.To .Cells(iRow + 2, 3) = olItem.SenderEmailAddress .Cells(iRow + 2, 4) = olItem.SenderName .Cells(iRow + 2, 5) = olItem.Subject .Cells(iRow + 2, 6) = olItem.ReceivedTime .Cells(iRow + 2, 7) = olItem.Body .Cells(iRow + 2, 8) = olItem.Size iRow = iRow + 1 End If Next olItem End With End Sub