VBA for Outlook not parsing email correctly - vba

Question

I am writing a VBA for outlook that will go through emails in my specific folder and go through the email's body and parse a specific line and then save it to an excel file. So far I am not getting any errors and when I run it, it saves an Excel file, but its only prints out an "email" string that I echo within the program, it's not parsed.
So I am having a bit of a problem parsing the proper information from the emails in the outlook folder. In matter of fact, I'm not sure if it's even parsing anything at all.
For iCtr = 1 To OutlookNameSpace.Folders.Item(1).Folders.Count
' handle case sensitivity as I can't type worth a crap
If LCase(OutlookNameSpace.Folders.Item(1).Folders(iCtr).Name) = LCase(strTargetFolder) Then
'found our target :)
Set outlookFolder = OutlookNameSpace.Folders.Item(1).Folders(iCtr)
Exit For ' found it so lets move on
End If
Next
'set up a header for the data dump, this is for CSV
strEmailContents = "Email" & vbCrLf
'likely should have some error handling here, in case we have found no target folder
'Set myFolderItem = outlookFolder.Items
' I have commenteted out some items to illustrate the call to Sue'strEmailContents Function
If Not outlookFolder Is Nothing Then
For Each outlookMessage In outlookFolder.Items
If TypeOf outlookMessage Is MailItem Then
strMsgBody = outlookMessage.Body ' assign message body to a Var
' then use Sue Moshers code to look for stuff in the body
' all of the following stuff in the quotes "" is specific to your needs
strEmailContents = strEmailContents & ParseTextLinePair(strMsgBody, "E-mail: ")
strEmailContents = strEmailContents & "," & ParseTextLinePair(strMsgBody, "")
'add the email message time stamp, just cause i want it
'debug message comment it out for production
'WScript.echo strEmailContents
End If
Next
End If
Here is my function to parse the lines:
Function ParseTextLinePair(strSource, strLabel)
' Sue Moshers code
'commented out type declaration for VBS usgage take out fer VB usage
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) ' this i like
End Function
Here is an example of an email I am trying to parse; i have put it in code format so it is easier to read.
Vendor: 22***********
Your company may be interested in the following advertisement(s).
To learn more about the advertisements below, please visit the
******** Vendor Bid System (VBS) at
http://www.****************.com. For specific
questions about the solicitation, each advertisement includes
contact information for the agency representative who issued it.
to view additional information on the advertisement(s) listed
below.
____________________________________________________________
Agency: ***************************************
Agency Ads: http://www.*************.com
Advertisement Number: ******BLACKEDOUT INFO***********
Advertisement Type: Informational Notice
Title: Centralized Customer Service System (CCSS) - Notice of Public Meeting
Advertisement Status: New
Agency Contact: Sheree *****
E-mail: blah#aol.com
Telephone: [phone]
Thank you in advanced!!

Answer 1

EDIT
Alright sir, give this a shot. Make sure you designate your folder and searchtext at the top. A message box will popup once the email has been extracted.
Sub ParseContents()
Dim strTargetFolder : strTargetFolder = "Inbox"
Dim SearchText: SearchText = "Email: "
Dim NS As outlook.NameSpace
Dim oFld As outlook.Folder
Set NS = Application.GetNamespace("MAPI")
For ifld = 1 To NS.Folders.Count
For ictr = 1 To NS.Folders.Item(ifld).Folders.Count
' handle case sensitivity as I can't type worth a crap
If LCase(NS.Folders.Item(ifld).Folders(ictr).Name) = LCase(strTargetFolder) Then
'found our target :)
Set oFld = NS.Folders.Item(ifld).Folders(ictr)
Exit For ' found it so lets move on
End If
Next
Next
'set up a header for the data dump, this is for CSV
strEmailContents = "Email" & vbCrLf
Dim EscapeLoops: EscapeLoops = False
'likely should have some error handling here, in case we have found no target folder
'Set myFolderItem = outlookFolder.Items
' I have commenteted out some items to illustrate the call to Sue'strEmailContents Function
If Not oFld Is Nothing Then
For Each outlookMessage In oFld.Items
If TypeOf outlookMessage Is MailItem Then
If InStr(outlookMessage.Body, SearchText) Then
strMsgBody = outlookMessage.Body ' assign message body to a Var
' then use Sue Moshers code to look for stuff in the body
' all of the following stuff in the quotes "" is specific to your needs
Dim splitter, parsemail: splitter = Split(strMsgBody, vbCrLf)
For Each splt In splitter
If InStr(splt, SearchText) Then
parsemail = splt
EscapeLoops = True
Exit For
End If
Next
strEmailContents = strEmailContents & "Date/Time: " & outlookMessage.CreationTime & vbCrLf
strEmailContents = strEmailContents & ParseTextLinePair(parsemail, SearchText)
MsgBox strEmailContents
If EscapeLoops Then Exit For
End If
End If
Next
End If
End Sub
Function ParseTextLinePair(strSource, strLabel)
Dim Rturn
If InStr(strSource, vbCrLf) Then
Rturn = Mid(strSource, InStr(strSource, strLabel) + Len(strLabel), InStr(strSource, vbCrLf) - InStr(strSource, strLabel) + Len(strLabel)):
Else
Rturn = Mid(strSource, InStr(strSource, strLabel) + Len(strLabel))
End If
ParseTextLinePair = Trim(Rturn)
End Function