将数据从电子邮件正文导出到 Outlook

Question

我经常收到格式一致的电子邮件，其中包含我想提取的数据以存储在 microsoft dynamics CRM 中。我相信最简单的方法是使用 VBA 将其导入 excel，然后使用 autohotkey 将其传输到 Web 表单中。

到目前为止，我有以下代码可以从电子邮件中提取数据，但我遇到了无关换行符的问题，希望得到一些反馈。

数据如下

Hi there, hope you are ok, lead is below.

-----Original Message-----
From: header waffle

The lead came through from the Lead Source: WEB FORM.
Date Received via Web: 10/10/2014 8:59 AM

Lead Information:

Their interests are: Orion water analysis instruments, Orion™ pH Electrode Filling Solution

blablabla 

Name: Joe Bloggs
Company: Generic Co.
Address:
line 1 line 2
Line 3 line 4
United Kingdom

Phone:  
Email: email@address.com 

Lead Notes: REF#:300100229
SKU:9003011
QTY:1
Customer Comments: 

ELMS ID: 00Q131M4f9vEAB

If you have any questions about this message, please contact me

Thank you.

我基于这个VBA Outlook. Trying to extract specific data from email body and export to Excel 编写代码，但是因为我正在处理更多不在并发行上的数据，所以它变得很麻烦，特别是因为所有额外的行返回。如何将数据剥离为我想要的，有没有更好的方法来处理多个数据片段？

代码如下：

Sub Extract()
    On Error GoTo 0
    Set myOlApp = Outlook.Application
    Set mynamespace = myOlApp.GetNamespace("mapi")

     Dim ThermoMail As Outlook.MailItem
    Set ThermoMail = Application.ActiveInspector.CurrentItem

    'open the current folder, I want to be able to name a specific folder if possible…
'Set myfolder = myOlApp.ActiveExplorer.CurrentFolder

    Set xlobj = CreateObject("excel.application.14")
    xlobj.Visible = True
    xlobj.Workbooks.Add
    'Set Headings

    xlobj.Range("A" & 1).Value = "Date Received via Web"
    xlobj.Range("A" & 2).Value = "Their interests are"
    xlobj.Range("A" & 3).Value = "Name"
    xlobj.Range("A" & 4).Value = "Company"
    xlobj.Range("A" & 5).Value = "Address"
    xlobj.Range("A" & 6).Value = "Phone"
    xlobj.Range("A" & 7).Value = "Email" '
    xlobj.Range("A" & 8).Value = "Lead Notes"
    xlobj.Range("A" & 9).Value = "SKU"
    xlobj.Range("A" & 10).Value = "QTY"
    xlobj.Range("A" & 11).Value = "Customer Comments"

    xlobj.Range("A" & 11).Value = ""

    Dim msgText As String
    msgText = ThermoMail.Body

    'search for specific text

    Dim delimtedMessage, Delim1 As String
    Delim1 = "###"

    delimtedMessage = Replace(delimtedMessage, "Date Received via Web:", "Delim1")
    delimtedMessage = Replace(delimtedMessage, "Their interests are:", "Delim1")
    delimtedMessage = Replace(msgText, "Purchasing Timeframe:", "Delim1")
    delimtedMessage = Replace(msgText, "Name:", "Delim1")
    delimtedMessage = Replace(delimtedMessage, "Company:", "Delim1")
    delimtedMessage = Replace(delimtedMessage, "Address:", "Delim1")
    delimtedMessage = Replace(delimtedMessage, "Phone:", "Delim1")
    delimtedMessage = Replace(delimtedMessage, "Email:", "Delim1")
    delimtedMessage = Replace(delimtedMessage, "Lead Notes:", "Delim1")
    delimtedMessage = Replace(delimtedMessage, "SKU:", "Delim1") '
    delimtedMessage = Replace(delimtedMessage, "QTY:", "Delim1")
    delimtedMessage = Replace(delimtedMessage, "Customer Comments:", "Delim1")
    delimtedMessage = Replace(delimtedMessage, "ELMS", "Delim1") 'everything after this should be discarded


    messageArray = Split(delimtedMessage, "Delim1")

    'write to excel
    'xlobj.Range("B" & 1).Value = messageArray(0) intentionally discarded
    xlobj.Range("B" & 1).Value = Trim(messageArray(1))
    xlobj.Range("B" & 2).Value = Trim(messageArray(2))
    xlobj.Range("B" & 3).Value = Trim(messageArray(3))
    xlobj.Range("B" & 4).Value = Trim(messageArray(4))
    xlobj.Range("B" & 5).Value = messageArray(5)
    xlobj.Range("B" & 6).Value = messageArray(6)
    xlobj.Range("B" & 7).Value = messageArray(7)
    xlobj.Range("B" & 8).Value = messageArray(8)
    xlobj.Range("B" & 9).Value = messageArray(9)
    xlobj.Range("B" & 10).Value = messageArray(10)
    xlobj.Range("B" & 11).Value = messageArray(11)

    End Sub

Answer 1

此处描述了从结构化文本中提取。

http://www.outlookcode.com/codedetail.aspx?id=89

https://msdn.microsoft.com/en-us/library/dd492012(v=office.12).aspx#Outlook2007ProgrammingCh17_ParsingTextFromAMessageBody

演示：

Sub Extract2()

    Dim objItem As Object
    Dim intLocAddress As Integer
    Dim intLocCRLF As Integer

    Dim strArray(11) As String

    Set objItem = Application.ActiveInspector.currentItem

    If objItem.Class = olMail Then

        strArray(0) = ParseTextLinePair(objItem.body, "Date Received via Web:")
        Debug.Print "Date Received via Web: " & strArray(0)

        strArray(1) = ParseTextLinePair(objItem.body, "Their interests are:")
        Debug.Print "Their interests are: " & strArray(1)

        strArray(2) = ParseTextLinePair(objItem.body, "Purchasing Timeframe:")
        Debug.Print "Purchasing Timeframe: " & strArray(2)

        strArray(3) = ParseTextLinePair(objItem.body, "Name:")
        Debug.Print "Name: " & strArray(3)

        strArray(4) = ParseTextLinePair(objItem.body, "Company:")
        Debug.Print "Company: " & strArray(4)

        strArray(5) = ParseTextLinePair(objItem.body, "Address:")
        Debug.Print "Address: " & strArray(5)

        strArray(6) = ParseTextLinePair(objItem.body, "Phone:")
        Debug.Print "Phone: " & strArray(6)

        strArray(7) = ParseTextLinePair(objItem.body, "Email:")
        Debug.Print "Email: " & strArray(7)

        strArray(8) = ParseTextLinePair(objItem.body, "Lead Notes:")
        Debug.Print "Lead Notes: " & strArray(8)

        strArray(9) = ParseTextLinePair(objItem.body, "SKU:")
        Debug.Print "SKU: " & strArray(9)

        strArray(10) = ParseTextLinePair(objItem.body, "QTY:")
        Debug.Print "QTY: " & strArray(10)

    End If

    Set objItem = Nothing

End Sub

Function ParseTextLinePair(strSource As String, strLabel As String)
    Dim intLocLabel As Integer
    Dim intLocCRLF As Integer
    Dim intLenLabel As Integer
    Dim strText As String

    ' locate the label in the source text
    intLocLabel = InStr(strSource, strLabel)
    intLenLabel = Len(strLabel)
        If intLocLabel > 0 Then
        intLocCRLF = InStr(intLocLabel, strSource, vbCrLf)
        If intLocCRLF > 0 Then
            intLocLabel = intLocLabel + intLenLabel
            strText = Mid(strSource, _
                            intLocLabel, _
                            intLocCRLF - intLocLabel)
        Else
            intLocLabel = Mid(strSource, intLocLabel + intLenLabel)
        End If
    End If
    ParseTextLinePair = Trim(strText)
End Function