Outlook vba developer reading message body from forwarded messages

Question

I have an vba script on outlook that reads a email message for keywords and outputs it to a csv file. The script works find if the email is addressed directly to me but the script breaks if it is a forwarded message from a friend. Any help is appreciated to edit the script to run properly when it is forwarded

Public Sub EidInfo(Item As Outlook.MailItem)
Dim CurrentMessage As MailItem
Dim MsgBody As String
Dim SearchPos As String
Dim SearchMsg(11) As String
Dim SearchStr(11) As String
Dim StartPos As Integer
Dim EndPos As Integer
Dim LineMsg As String

Set CurrentMessage = Item

MsgBody = CurrentMessage.HTMLBody

SearchStr(1) = "Requester "
SearchStr(2) = "Flight "
SearchStr(3) = "Request Type:-"
SearchStr(4) = "Summary : "
SearchStr(5) = "Description : "
SearchStr(6) = "Reason : "
SearchStr(7) = "Number : "
SearchStr(8) = "From Date : "
SearchStr(9) = "To Date : "
SearchStr(10) = "Number of Days : "
SearchStr(11) = "Country : "

EndPos = 1

For i = 1 To 11
    StartPos = InStr(EndPos, MsgBody, SearchStr(i), vbTextCompare) + Len(SearchStr(i))

    If i = 1 Then
        EndPos = StartPos + 15
    ElseIf i = 2 Then
        EndPos = InStr(StartPos, MsgBody, ".", vbTextCompare)
    ElseIf i = 11 Then
        EndPos = InStr(StartPos, MsgBody, "<BR>", vbTextCompare)
    Else
        EndPos = InStr(StartPos, MsgBody, "<BR>" + SearchStr(i + 1), vbTextCompare)
    End If

    SearchMsg(i) = Mid(MsgBody, StartPos, EndPos - StartPos)
    SearchMsg(i) = Replace(SearchMsg(i), "<BR>", " ")
    SearchMsg(i) = Replace(SearchMsg(i), ",", ".")
Next i

If Dir("D:\EidFile.csv") = "" Then
    Open "D:\EidFile.csv" For Output As #1

    LineMsg = "Request Time,"

    For i = 1 To 11
        LineMsg = LineMsg + Replace(SearchStr(i), ":", " ")
        If i < 11 Then LineMsg = LineMsg + ","
    Next i

    Print #1, LineMsg
    LineMsg = ""
Else
    Open "D:\EidFile.csv" For Append As #1
End If

LineMsg = CurrentMessage.ReceivedTime
LineMsg = LineMsg + ","

For i = 1 To 11
    LineMsg = LineMsg + SearchMsg(i)
    If i < 11 Then LineMsg = LineMsg + ","
Next i

Print #1, LineMsg

Close #1

End Sub

When do you run the script? Could you be more specific? Did you try to debug the code when the script is run against the forwarded email manually? — Eugene Astafiev

niton niton · Accepted Answer · 2015-02-08T23:16:50

It looks like you have lines consisting of a label followed by variable text. A method to parse text from a structured block is described here.

17.2 Parsing text from a message body

The example looks for the text associated with the label "Email:"

Sub FwdSelToAddr()
    Dim objOL As Outlook.Application
    Dim objItem As Object
    Dim objFwd As Outlook.MailItem
    Dim strAddr As String
    On Error Resume Next
    Set objOL = Application
    Set objItem = objOL.ActiveExplorer.Selection(1)
    If Not objItem Is Nothing Then
        strAddr = ParseTextLinePair(objItem.Body, "Email:")
        If strAddr <> "" Then
            Set objFwd = objItem.Forward
            objFwd.To = strAddr
            objFwd.Display
        Else
            MsgBox "Could not extract address from message."
        End If
    End If
    Set objOL = Nothing
    Set objItem = Nothing
    Set objFwd = 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
    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

You will likely use something like:

SearchMsg(i) = ParseTextLinePair(CurrentMessage.Body, SearchStr(i))

Outlook vba developer reading message body from forwarded messages

1 Answers