Question

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

我写了一些VBA代码。当多个电子邮件地址位于此字段中时， .To 功能不起作用（提供即时错误）。 .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-email-folder，但除此之外还有其他项目，即＆＃34; MeetingItem＆＃34;。有几个项目可以驻留在这些文件夹中，但没有.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

读取到CC和BCC属性时出错

1 个答案: