带有 ConversationID 的批量出口前景信件

Question

我需要将所有带有标准 Outlook 字段（发件人/收件人/主题/日期，包括类别，最重要的是 ConversationID）的电子邮件提取到 Excel/csv 中。 我使用的是 MS Office 2016，不知道 Exchange 服务器的版本。

我在邮箱上尝试了几种方法： 1）通过标准outlook界面导出数据 2) 通过标准导出主机将数据导出到 MS 访问 3) 直接从 MS Exchange 提取数据到 MS PowerBI

在所有 3 种情况下，我都无法获得 ConversationID（PowerBI 提取有一些 ID，但不是 ConversationID）

现在我知道它应该以某种方式通过 MAPI 提取，但我完全不了解这个主题。一些搜索建议为此使用特殊软件，例如 Transcend，但对于一个用户来说显然太贵了:)

我还发现 VBA 代码可以直接将数据导入 Excel，但它对我不起作用： http://www.tek-tips.com/viewthread.cfm?qid=1739523 还发现了这个很好的解释什么是 ConversationID - 可能对其他感兴趣的主题有帮助： https://www.meridiandiscovery.com/how-to/e-mail-conversation-index-metadata-computer-forensics/

Answer 1

这里有一些示例代码可以帮助您入门，我已经有了与您的问题类似的内容。代码已注释，但请随时提出问题:)

Option Explicit

Public Sub getEmails()
On Error GoTo errhand:

    'Create outlook objects and select a folder
    Dim outlook     As Object: Set outlook = CreateObject("Outlook.Application")
    Dim ns          As Object: Set ns = outlook.GetNameSpace("MAPI")

    'This option open a new window for you to select which folder you want to work with
    Dim olFolder    As Object: Set olFolder = ns.pickFolder
    Dim emailCount  As Long: emailCount = olFolder.Items.Count
    Dim i           As Long
    Dim myArray     As Variant
    Dim item        As Object

    ReDim myArray(4, (emailCount - 1))

    For i = 1 To emailCount
        Set item = olFolder.Items(i)
        '43 is olMailItem, only consider this type of email message
        'I'm assuming you only want items with a conversationID
        'Change the logic here to suite your specific needs
        If item.Class = 43 And item.ConversationID <> vbNullString Then
            'Using an array to write to excel in one go
            myArray(0, i - 1) = item.Subject
            myArray(1, i - 1) = item.SenderName
            myArray(2, i - 1) = item.To
            myArray(3, i - 1) = item.CreationTime
            myArray(4, i - 1) = item.ConversationID
        End If
    Next

    'Adding headers, then writing the data to excel
    With ActiveSheet
        .Range("A1") = "Subject"
        .Range("B1") = "From"
        .Range("C1") = "To"
        .Range("D1") = "Created"
        .Range("E1") = "ConversationID"
        .Range("A2:E" & (emailCount + 1)).Value = TransposeArray(myArray)
    End With

    Exit Sub

errhand:
    Debug.Print Err.Number, Err.Description
End Sub

'This function is used to bypass the limitation of -
'application.worksheetfunction.transpose
'If you have too much data added to an array you'll get a type mismatch
'Found here - http://bettersolutions.com/vba/arrays/transposing.htm
Public Function TransposeArray(myArray As Variant) As Variant
    Dim X           As Long
    Dim Y           As Long
    Dim Xupper      As Long: Xupper = UBound(myArray, 2)
    Dim Yupper      As Long: Yupper = UBound(myArray, 1)
    Dim tempArray   As Variant

    ReDim tempArray(Xupper, Yupper)

    For X = 0 To Xupper
        For Y = 0 To Yupper
            tempArray(X, Y) = myArray(Y, X)
        Next
    Next

    TransposeArray = tempArray
End Function