Question : Parse Text From Outlook Body Using VBA

Using the following code example (created by/reference http://www.experts-exchange.com/Excel/Q_23979946.html) I am trying to figure out how to parse only the 3rd line of text from an Outlook 2003 email body and then set that to a variable. The parse search should look for "Core Data" and then take the 3rd line and set that to a variable.

Note: I have yet to add the requested functionality to the code below.

An example of the body text is;

Core Data
"Status","Location","Score","Time"
"passed","98","100","12:16:28"

Code Snippet:

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:



45722044459904530984445990Sub GetInbox()
    Dim olApp, olNamespace, olInbox, olItem
    Dim strFileName As String, objFS, objTS
    Set olApp = CreateObject("Outlook.Application")
    Set olNamespace = olApp.GetNamespace("MAPI")
    Set olInbox = olNamespace.GetDefaultFolder(6)
  
    strFileName = "c:\test.csv"
    Set objFS = CreateObject("Scripting.FileSystemObject")
    On Error Resume Next
    Set objTS = objFS.getfile(strFileName)
    If Err.Number <> 0 Then objFS.CreateTextFile strFileName
    On Error GoTo 0
    Set objTS = objFS.OpenTextFile(strFileName, 8)
 
    On Error Resume Next
    For Each olItem In olInbox.items
        objTS.Write olItem.SenderName & ", " & olItem.Subject & ", " & olItem.ReceivedTime & ", " & olitem.body
    objTS.writeline
    Next
 
    objTS.Close
    Set olApp = Nothing
End Sub
241258498273000
251259107364000

Open in New Window

Select All

Answer : Parse Text From Outlook Body Using VBA

thx S,

I had missed these responses

@ aehare70,

Please try this updated pattern match including spaces

Dave

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:



Const LineFeed As String = "&&&"
Sub GetInbox()
    Dim olApp, olNamespace, olInbox, olItem
    Dim regex, REGM
    Dim tmpStr As String, myVar As String
    strFileName = "c:\test.csv"
    Set objFS = CreateObject("Scripting.FileSystemObject")
    On Error Resume Next
    Set objTS = objFS.getfile(strFileName)
    If Err.Number <> 0 Then objFS.CreateTextFile strFileName
    On Error GoTo 0
    Set objTS = objFS.OpenTextFile(strFileName, 8)
 
 
    Set regex = CreateObject("vbscript.regexp")
    Set olApp = CreateObject("Outlook.Application")
    Set olNamespace = olApp.GetNamespace("MAPI")
    Set olInbox = olNamespace.GetDefaultFolder(6).Folders("temp")
 
    strFileName = "c:\test.csv"
    Set objFS = CreateObject("Scripting.FileSystemObject")
    On Error Resume Next
    Set objTS = objFS.getfile(strFileName)
    If Err.Number <> 0 Then objFS.CreateTextFile strFileName
    On Error GoTo 0
    Set objTS = objFS.OpenTextFile(strFileName, 8)
 
 
    With regex
        .Pattern = "[\f\r\n\t]{1}"
        .Global = True
        .MultiLine = True
        .IGNORECASE = True
 
        For Each olItem In olInbox.items
            tmpStr = .Replace(olItem.body, LineFeed)
            .Pattern = "Core Data\s{1,}" & LineFeed & "{1,}(.+?)" & LineFeed & "{1,}(.+?)" & LineFeed
            myVar = vbNullString
            If .test(tmpStr) Then
                Set REGM = .Execute(tmpStr)
                myVar = Replace(Replace(REGM(0).submatches(1), LineFeed, vbNullString), ",", ":")
            End If
            objTS.Write olItem.SenderName & ", " & olItem.Subject & ", " & olItem.ReceivedTime & ", " & myVar
            objTS.writeline
         Next
    End With
    objTS.Close
     Set olApp = Nothing
End Sub

Open in New Window

Select All