批量导出outlook字母与对话ID

Question

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

我尝试了几种方法来对我的邮箱这样做： 1）通过标准前景接口 2导出的数据）导出的数据到通过标准的出口主 3 MS访问）从MS交换直接

提取的数据到MS PowerBI

在所有3种情况下，我是不是能够得到的conversationId（PowerBI提取了一些ID，但它不是的conversationId）

现在我明白了，它应该通过MAPI莫名其妙地被提取，但我对这个完全是文盲话题。一些搜索建议使用专门的软件，像创见，但它显然过于昂贵，一个用户:)

我还发现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