讀取CC和BCC屬性時出錯

Question

我試圖將所有電子郵件解壓到外部程序（AIMMS）。我首先將它全部存儲在Excel中以供閱讀。

我寫了一些VBA代碼。當該字段中有多個電子郵件地址時，。至函數不起作用（導致即時錯誤）。 .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-property。

所以，你需要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