Exporting data from email body into outlook

Question

I regularly get consistently formatted emails with data which I'd like to extract for storage in microsoft dynamics CRM. I believe the easiest way to do this is to use VBA to take it into excel and then autohotkey to transfer it into the web form.

So far I have the following code to extract the data from the email but I'm having problems with extraneous line breaks and would like some feedback.

The data is as follows

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.

I based the code on this VBA Outlook. Trying to extract specific data from email body and export to Excel but because I am handling more data which is not on concurrent lines it has become hacky, especially because of all the extra line returns. How can I strip the data to be just what I want, and is there a nicer way to handle the multiple fragments of data?

The code is as follows:

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

Extracting from structured text is described here.

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

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

Demo:

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