How to recursively parse data out of an e-mail using VBA? - vba

Question

So I get e-mails every day with information in them. Unfortunately, for some reason, the data is sent in the body of the e-mail, and not as an attachment. Fine then. I'm using Excel to scrape Outlook, using VBA.
Sub mytry()
Dim olapp As Object
Dim olmapi As Object
Dim olmail As Object
Dim olitem As Object
Dim lrow As Integer
Dim olattach As Object
Dim str As String
Dim TextWeNeedToParse as String
Const num As Integer = 6
Const path As String = "C:\HP\"
Const emailpath As String = "C:\Dell\"
Const olFolderInbox As Integer = 6
Set olp = CreateObject("outlook.application")
Set olmapi = olp.getnamespace("MAPI")
Set olmail = olmapi.getdefaultfolder(num)
If olmail.items.restrict("[ReceivedTime]>=""&MacroDate&12:00am&""").Count = 0 Then
Else
For Each olitem In olmail.items.restrict("[ReceivedTime]>=""&MacroDate&12:00am&""")
TextWeNeedToParse = olitem.body
'Recursive text parsing here
Next olitem
End If
Ok, so this code snippet should get me the entire body of the text into a string. Now we can pass the string around, and manipulate it.
A sample of the text I'm dealing with:
WAL +300bp QTY
(M) FCTR SECURITY CPN ASK 1mPSA TYPE
0.77 1.15 458 0.04 GNR 2012-61 CA 2.00 99-16 217 SEQ
1.39 2.26 120 0.76 GNR 2005-13 AE 5.00 102-24 223 SUP
1.40 18.16 45 0.65 GNR 2015-157 NH 2.50 95-16 215 EXCH,+
1.50 21.56 25 0.94 GNR 2017-103 HD 3.00 98-08 375 PAC-2
So there are a few different ways I can see myself tackling this, but I don't quite know all of the pieces.
1) I could try counting how many carriage returns exist, and doing a loop. Then "counting" spaces to figure out where everything is. Not quite sure how well it would work.
2) I could regex out the unique ID in the middle, and if I can figure out how to regex the nth instance (a major point where I'm stuck), I could also use that to regex out the numbers - for example, line one would be the 1-5 instance of straight numbers/decimals together surrounded by spaces, and the first instance of number-number-dash-number-number.
Sample Regex Code that I'd throw through it:
Function regex(strInput As String, matchPattern As String, Optional ByVal outputPattern As String = "$0") As Variant
Dim inputRegexObj As New VBScript_RegExp_55.RegExp, outputRegexObj As New VBScript_RegExp_55.RegExp, outReplaceRegexObj As New VBScript_RegExp_55.RegExp
Dim inputMatches As Object, replaceMatches As Object, replaceMatch As Object
Dim replaceNumber As Integer
With inputRegexObj
.Global = True
.MultiLine = True
.IgnoreCase = False
.Pattern = matchPattern
End With
With outputRegexObj
.Global = True
.MultiLine = True
.IgnoreCase = False
.Pattern = "\$(\d+)"
End With
With outReplaceRegexObj
.Global = True
.MultiLine = True
.IgnoreCase = False
End With
Set inputMatches = inputRegexObj.Execute(strInput)
If inputMatches.Count = 0 Then
regex = False
Else
Set replaceMatches = outputRegexObj.Execute(outputPattern)
For Each replaceMatch In replaceMatches
replaceNumber = replaceMatch.SubMatches(0)
outReplaceRegexObj.Pattern = "\$" & replaceNumber
If replaceNumber = 0 Then
outputPattern = outReplaceRegexObj.Replace(outputPattern, inputMatches(0).Value)
Else
If replaceNumber > inputMatches(0).SubMatches.Count Then
'regex = "A to high $ tag found. Largest allowed is $" & inputMatches(0).SubMatches.Count & "."
regex = CVErr(xlErrValue)
Exit Function
Else
outputPattern = outReplaceRegexObj.Replace(outputPattern, inputMatches(0).SubMatches(replaceNumber - 1))
End If
End If
Next
regex = outputPattern
End If
End Function
3) I could try some of the methods above, but use recursion. My recursion is fairly weak.
So once I have the text string extracted, I imagine I'd need something like:
Sub QuickExample(Dim Cusip as String, Dim PriceStr as variant, Dim SpreadStr as variant)
Dim ws as WorkSheet
Set ws = thisworkbook.sheets("Results")
LastRow = ws.Cells(sht.Rows.Count, "A").End(xlUp).Row
ws.cells(Lastrow,1).value2 = Cusip
ws.cells(Lastrow,2).value2 = PriceStr
ws.cells(Lastrow,3).value2 = SpreadStr
End Sub
And lastly:
Sub ParsingDate(EmailText as String)
Dim CarriageReturns As Long
CarriageReturns = Len(EmailText) - Len(Replace(EmailText, Chr(10), ""))
For i = 1 to CarriageReturns
'Parse out the data for the ith row, return it to the function above
Next i
End Sub
It's the actual act of parsing which I'm struggling a bit with - how do I properly get the nth result, and only the nth result? How do I make sure it keeps working even if some extra spaces or lines get added? Is there a way to just use regex, and "look" around the nth finding of a given expression? Is it doable to make this without a lot of recursion?
Thank you

Answer 1

WAL +300bp QTY
(M) FCTR SECURITY CPN ASK 1mPSA TYPE
0.77 1.15 458 0.04 GNR 2012-61 CA 2.00 99-16 217 SEQ
1.39 2.26 120 0.76 GNR 2005-13 AE 5.00 102-24 223 SUP
1.40 18.16 45 0.65 GNR 2015-157 NH 2.50 95-16 215 EXCH,+
1.50 21.56 25 0.94 GNR 2017-103 HD 3.00 98-08 375 PAC-2
This seems like a pretty well formatted table. Perhaps pop each line into an array using Split() and then each field into an array, again using split():
Sub dump()
arrLine = Split(TextWeNeedToParse, Chr(10))
For Each Line In arrLine
For Each field In Split(Line, " ")
Debug.Print field
Next
Next
End Sub
That's super short and runs quick. You are just an if statement and counter (or regex test) away from getting the exact items you want.
Testing/counting may be easier if you remove multiple spaces so the split() puts each element in it's proper place. You could employee a loop to remove multiple spaces before running this:
Fully implemented it might be something like:
<your code to get the bod>
'remove multiple spaces from string for parsing
Do While InStr(1, TextWeNeedToParse, " ")
TextWeNeedToParse= Replace(TextWeNeedToParse, " ", " ")
Loop
'Get each line into an array element
arrLine = Split(TextWeNeedToParse, Chr(10))
'Loop through the array
For Each Line In arrLine
'dump fields to an array
arrFields = Split(Line, " ")
'and spit out a particular element (your "unique id" is element 5)
If UBound(arrFields) >= 5 Then Debug.Print "unique id:"; arrFields(5)
Next