使用ConversationID批量导出outlook信件

Question

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

我在我的邮箱上尝试了几种方法: 1)通过标准outlook接口导出数据2)通过标准导出主机将数据导出到MS access 3)直接从MS PowerBI提取数据到MS Exchange

在所有3种情况下，我都无法获得ConversationID (PowerBI extract有一些ID，但它不是ConversationID)

现在我知道它应该以某种方式通过MAPI提取出来，但我对这个话题一无所知。一些搜索建议使用特殊的软件，比如Transcend，但对一个用户来说显然太贵了:)

我还找到了直接将数据放入Excel的VBA代码，但它对我不起作用：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