无论如何要将电子邮件导出到包含附件的文件夹？

Question

我有一个我超时创建的系统，可以将电子邮件数据放到 Excel 电子表格中。这很好，但运行后我还想做的是将包括 Outlook 中的任何附件的电子邮件提取到我的 Windows PC 上的新文件夹中。

当电子邮件位于 Excel 电子表格中，然后将电子邮件和附件提取到我的 PC 上的文件夹中时，我希望将唯一 ID（可能是电子邮件的日期，或者只是一个随机数）添加到该电子邮件将自动将链接地址发送回已提取的电子邮件旁边的电子表格，并将唯一 ID 添加到电子表格中。听起来有点混乱，我希望这是有道理的（这可能吗？）

人们会回复电子邮件，我还希望回复电子邮件到原始电子邮件（应具有上面列出的唯一 ID）使用与原始电子邮件相同的 ID。再次抱歉，如果这听起来令人困惑，很高兴在需要时更详细地介绍。

像这样的东西有点新，所以任何帮助都会很棒。

这是我目前写的代码；

Sub Download_Outlook_Mail_To_Excel()
    'Add Tools->References->"Microsoft Outlook nn.n Object Library"
    'nn.n varies as per our Outlook Installation
    Dim Folder As Outlook.MAPIFolder
    Dim sFolders As Outlook.MAPIFolder
    Dim iRow As Integer, oRow As Integer
    Dim MailBoxName As String, Pst_Folder_Name  As String

    'Mailbox or PST Main Folder Name (As how it is displayed in your Outlook Session)
    MailBoxName = "neo_segauk@hotmail.com"

    'Mailbox Folder or PST Folder Name (As how it is displayed in your Outlook Session)
    Pst_Folder_Name = "Inbox" 'Sample "Inbox" or "Sent Items"

    'To directly a Folder at a high level
    'Set Folder = Outlook.Session.Folders(MailBoxName).Folders(Pst_Folder_Name)

    'To access a main folder or a subfolder (level-1)
    For Each Folder In Outlook.Session.Folders(MailBoxName).Folders
        If VBA.UCase(Folder.Name) = VBA.UCase(Pst_Folder_Name) Then GoTo Label_Folder_Found
        For Each sFolders In Folder.Folders
            If VBA.UCase(sFolders.Name) = VBA.UCase(Pst_Folder_Name) Then
                Set Folder = sFolders
                GoTo Label_Folder_Found
            End If
        Next sFolders
    Next Folder

Label_Folder_Found:
     If Folder.Name = "" Then
        MsgBox "Invalid Data in Input"
        GoTo End_Lbl1:
    End If

    'Read Through each Mail and export the details to Excel for Email Archival
    ThisWorkbook.Sheets(1).Activate
    Folder.Items.Sort "Received"

    'Insert Column Headers
    ThisWorkbook.Sheets(1).Cells(1, 1) = "Sender"
    ThisWorkbook.Sheets(1).Cells(1, 2) = "Subject"
    ThisWorkbook.Sheets(1).Cells(1, 3) = "Date"
    'ThisWorkbook.Sheets(1).Cells(1, 4) = "Size"
    ThisWorkbook.Sheets(1).Cells(1, 5) = "EmailID"
    ThisWorkbook.Sheets(1).Cells(1, 6) = "Body"

    'Export eMail Data from PST Folder
    oRow = 1
    For iRow = 1 To Folder.Items.Count
        'If condition to import mails received in last 60 days
        'To import all emails, comment or remove this IF condition
        'If VBA.DateValue(VBA.Now) - VBA.DateValue(Folder.Items.Item(iRow).ReceivedTime) <= 60 Then
           oRow = oRow + 1
           ThisWorkbook.Sheets(1).Cells(oRow, 1).Select
           ThisWorkbook.Sheets(1).Cells(oRow, 1) = Folder.Items.Item(iRow).SenderName
           ThisWorkbook.Sheets(1).Cells(oRow, 2) = Folder.Items.Item(iRow).Subject
           ThisWorkbook.Sheets(1).Cells(oRow, 3) = Folder.Items.Item(iRow).ReceivedTime
           'ThisWorkbook.Sheets(1).Cells(oRow, 4) = Folder.Items.Item(iRow).Size
           ThisWorkbook.Sheets(1).Cells(oRow, 5) = Folder.Items.Item(iRow).SenderEmailAddress
           ThisWorkbook.Sheets(1).Cells(oRow, 6) = Folder.Items.Item(iRow).Body
        'End If
    Next iRow
    MsgBox "Outlook Mails Extracted to Excel"
    Set Folder = Nothing
    Set sFolders = Nothing

End_Lbl1:
End Sub

Answer 1

代替你的 for 循环，你可以这样做：

Dim msg As Outlook.MailItem 
...

For Each msg in Folder.Items

    'You can access here each message properties, like msg.attachments...
     ThisWorkbook.Sheets(1).Cells(oRow, 1) = msg.Attachments.Item(1).FileName
     ...
     msg.Attachments.Item(1).SaveAsFile "C:\...."

Next