Cannot extract data from outlook message body using excel macro

[scottluz]

I am using this macro to extract data from an outlook message body. It will not grab any of the data that I need from the body, but will set up the Headers in excel. I can see data in the temp file but it is not transferring.

****** http-equiv="Content-Type" content="text/html; charset=utf-8">****** name="ProgId" content="Word.Document">****** name="Generator" content="Microsoft Word 11">****** name="Originator" content="Microsoft Word 11"><link rel="File-List" href="file:///C:%5CDOCUME%7E1%5Csluzinas%5CLOCALS%7E1%5CTemp%5Cmsohtml1%5C01%5Cclip_filelist.xml"><!--[if gte mso 9]><xml> <w:WordDocument> <w:View>Normal</w:View> <w:Zoom>0</w:Zoom> <w:PunctuationKerning/> <w:ValidateAgainstSchemas/> <w:SaveIfXMLInvalid>false</w:SaveIfXMLInvalid> <w:IgnoreMixedContent>false</w:IgnoreMixedContent> <w:AlwaysShowPlaceholderText>false</w:AlwaysShowPlaceholderText> <w:Compatibility> <w:BreakWrappedTables/> <w:SnapToGridInCell/> <w:WrapTextWithPunct/> <w:UseAsianBreakRules/> <w:DontGrowAutofit/> </w:Compatibility> <w:BrowserLevel>MicrosoftInternetExplorer4</w:BrowserLevel> </w:WordDocument> </xml><![endif]--><!--[if gte mso 9]><xml> <w:LatentStyles DefLockedState="false" LatentStyleCount="156"> </w:LatentStyles> </xml><![endif]--><style> <!-- /* Style Definitions */ p.MsoNormal, li.MsoNormal, div.MsoNormal {mso-style-parent:""; margin:0in; margin-bottom:.0001pt; mso-pagination:widow-orphan; font-size:12.0pt; font-family:"Times New Roman"; mso-fareast-font-family:"Times New Roman";} @page Section1 {size:8.5in 11.0in; margin:1.0in 1.25in 1.0in 1.25in; mso-header-margin:.5in; mso-footer-margin:.5in; mso-paper-source:0;} div.Section1 {page:Section1;} --> </style><!--[if gte mso 10]> <style> /* Style Definitions */ table.MsoNormalTable {mso-style-name:"Table Normal"; mso-tstyle-rowband-size:0; mso-tstyle-colband-size:0; mso-style-noshow:yes; mso-style-parent:""; mso-padding-alt:0in 5.4pt 0in 5.4pt; mso-para-margin:0in; mso-para-margin-bottom:.0001pt; mso-pagination:widow-orphan; font-size:10.0pt; font-family:"Times New Roman"; mso-ansi-language:#0400; mso-fareast-language:#0400; mso-bidi-language:#0400;} </style> <![endif]--> Option Explicit
<o> </o>
Sub ReadInbox()
Dim OutlookApp As Object
Dim OA_NameSpace As Object
Dim OA_Folder As Object
Dim OA_MailItem As Object
<o> </o>
Dim ws As Worksheet
<o> </o>
Dim Created As Boolean
<o> </o>
Dim NextRecord As Long
<o> </o>
Application.ScreenUpdating = False
<o> </o>
Set ws = Workbooks.Add(xlWorksheet).Sheets(1)
<o> </o>
ws.[A1] = "Name"
ws.[B1] = "E-Mail"
'ws.[C1] = "subject"
'ws.[D1] = "REMOTE_HOST"
<o> </o>
NextRecord = 2
<o> </o>
On Error Resume Next
Set OutlookApp = GetObject("Outlook.Application")
If OutlookApp Is Nothing Then
Set OutlookApp = CreateObject("Outlook.Application")
Created = True
If OutlookApp Is Nothing Then
MsgBox "Unable to start Outlook."
Exit Sub
End If
End If
On Error GoTo 0
<o> </o>
Set OA_NameSpace = OutlookApp.GetNamespace("MAPI")
'Set OA_Folder = OA_NameSpace.GetDefaultFolder(6)
'Set OA_Folder = OA_NameSpace."Customer Service"
Set OA_Folder = OA_NameSpace.PickFolder
'Set OA_Folder = OA_NameSpace.Folders("Scott Luzinas").Folders("Customer Service")
<o> </o>
OA_Folder.Items.Sort "Received", True
<o> </o>
For Each OA_MailItem In OA_Folder.Items
Dim OrderInfo As Variant
<o> </o>
OrderInfo = GrabInfo(OA_MailItem.Body)
<o> </o>
If IsArray(OrderInfo) Then
ws.Range(Cells(NextRecord, 1), Cells(NextRecord, 2)) = OrderInfo
NextRecord = NextRecord + 1
End If
Next
<o> </o>
Application.ScreenUpdating = True
<o> </o>
Set OA_Folder = Nothing
Set OA_NameSpace = Nothing
Set OutlookApp = Nothing
End Sub
<o> </o>
Private Function GrabInfo(message As String) As Variant
Dim tmpInfo(4) As String
<o> </o>
Dim f As Integer
<o> </o>
Const TMPFILE As String = "C:\temp\outlook_extraction.tmp"
<o> </o>
If message = vbNullString Then GrabInfo = vbNullString: Exit Function
<o> </o>
f = FreeFile
<o> </o>
Open TMPFILE For Output As #f
Write #f, message
Close #f
<o> </o>
f = FreeFile
<o> </o>
Open TMPFILE For Input As #f
<o> </o>
Do While Not EOF(f)
Dim tmpLine As String
<o> </o>
Line Input #f, tmpLine
<o> </o>
If InStr(1, tmpLine, "=") Then
Select Case UCase(Left(tmpLine, InStr(1, tmpLine, "=") - 1))
Case "Name": tmpInfo(0) = SplitString(tmpLine, "=")
Case "E-Mail": tmpInfo(1) = SplitString(tmpLine, "=")
'Case "subject": tmpInfo(1) = SplitString(tmpLine, "=")
'Case "REMOTE_HOST": tmpInfo(1) = SplitString(tmpLine, "=")
<o> </o>
End Select
End If
Loop
<o> </o>
Close #f
<o> </o>
'Kill TMPFILE
<o> </o>
GrabInfo = tmpInfo
End Function
<o> </o>
Private Function SplitString(value As String, delimeter As String) As String
SplitString = Trim(Mid(value, InStr(1, value, delimeter) + 2, Len(value) - InStr(1, value, delimeter)))
End Function
<o> </o>
End Function