从电子邮件（或数千封电子邮件）中提取数据 [基于 Exchange]答案

【问题标题】：Extracting data from an email message (or several thousand emails) [Exchange based]从电子邮件（或数千封电子邮件）中提取数据 [基于 Exchange]
【发布时间】：2008-12-30 00:05:27
【问题描述】：

祝福他们，我的营销部门决定进行一次抽奖活动，让人们通过网页进入。这很好，但信息不会存储到任何类型的数据库中，而是作为电子邮件发送到交换邮箱。太好了。

我的挑战是从这些电子邮件中提取条目（和营销信息）并将它们存储在更有用的地方，例如平面文件或 CSV。唯一的优点是电子邮件具有高度一致的格式。

我确信我可以花时间将所有电子邮件保存到文件中，然后编写一个应用程序来处理它们，但我希望有一个更优雅的解决方案。我可以以编程方式访问交换邮箱，阅读所有电子邮件，然后保存这些数据吗？

【问题讨论】：

标签： exchange-server text-extraction

【解决方案1】：

这是我使用的代码....

Private Sub btnGo_Click()
  If ComboBox1.SelText <> "" Then
    Dim objOutlook As New Outlook.Application
    Dim objNameSpace As Outlook.NameSpace
    Dim objInbox As MAPIFolder
    Dim objMail As mailItem

    //Get the MAPI reference
    Set objNameSpace = objOutlook.GetNamespace("MAPI")

    //Pick up the Inbox
    Set objInbox = objNameSpace.GetDefaultFolder(olFolderInbox)
    For Each objFolder In objInbox.Folders
       If (objFolder.Name = ComboBox1.SelText) Then
          Set objInbox = objFolder
       End If
    Next objFolder

    //Loop through the items in the Inbox
    Dim count As Integer
    count = 1

    For Each objMail In objInbox.Items
       lblStatus.Caption = "Count: " + CStr(count)
       If (CheckBox1.Value = False Or objMail.UnRead = True) Then
          ProcessMailItem (objMail.Body)
          count = count + 1
          objMail.UnRead = False
       End If
    Next objMail
  End If
End Sub

Private Sub ProcessMailItem(strBody As String)
   Open "C:\file.txt" For Append As 1

   Dim strTmp As String
   strTmp = Replace(strBody, vbNewLine, " ")
   strTmp = Replace(strTmp, vbCrLf, " ")
   strTmp = Replace(strTmp, Chr(13) & Chr(10), " ")
   strTmp = Replace(strTmp, ",", "_")

   //Extra Processing went here (Deleted for brevity)
   Print #1, strTmp
   Close #1

End Sub

Private Function Strip(strStart As String, strEnd As String, strBody As String) As String
   Dim iStart As Integer
   Dim iEnd As Integer

   iStart = InStr(strBody, strStart) + Len(strStart)
   If (strEnd = "xxx") Then
      iEnd = Len(strBody)
   Else
      iEnd = InStr(strBody, strEnd) - 1
   End If

   Strip = LTrim(RTrim(Mid(strBody, iStart, iEnd - iStart)))
End Function


Private Sub UserForm_Initialize()
  Dim objOutlook As New Outlook.Application
  Dim objNameSpace As Outlook.NameSpace
  Dim objInbox As MAPIFolder
  Dim objFolder As MAPIFolder

  //Get the MAPI reference
  Set objNameSpace = objOutlook.GetNamespace("MAPI")

  //Pick up the Inbox
  Set objInbox = objNameSpace.GetDefaultFolder(olFolderInbox)

  //Loop through the folders under the Inbox
  For Each objFolder In objInbox.Folders
    ComboBox1.AddItem objFolder.Name
  Next objFolder
End Sub

【讨论】：

酷。很高兴您在发布代码方面做得很好并且做得很好，这样其他人可以在以后在谷歌出现时受益。
2012 年，它作为谷歌搜索的第一个结果弹出并立即有用 - 它让一个想要统计分析他的邮件流的疲惫的人非常高兴！ :)

【解决方案2】：

有很多不同的方法可以获取 Exchange 邮箱中的消息，但由于您似乎只想运行一次以提取数据，因此我建议您编写一个 VBA 宏以在其中运行Outlook 本身（在 Outlook 中打开了有问题的交换邮箱）。遍历特定邮箱中的邮件项目并从中读取正文非常容易。然后，您可以编写一个包含您想要的内容的文本文件。

【讨论】：

我一定会试一试。我会回来报告的。 :)