Extract Text from body of outlook message to excel

[scottluz]

I have been trying to make a macro work for me, but the problem I am running into is that i cannot get the macro to grab the correct folder in Outlook. The macro I am running is as such:

Option Explicit

Sub ReadInbox()
Dim OutlookApp As Object
Dim OA_NameSpace As Object
Dim OA_Folder As Object
Dim OA_MailItem As Object

Dim ws As Worksheet

Dim Created As Boolean

Dim NextRecord As Long

Application.ScreenUpdating = False

Set ws = Workbooks.Add(xlWorksheet).Sheets(1)

ws.[A1] = "Name"
ws.[B1] = "E-mail"

NextRecord = 2

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

Set OA_NameSpace = OutlookApp.GetNamespace("MAPI")
Set OA_Folder = OA_NameSpace.GetDefaultFolder(6)


OA_Folder.Items.Sort "Received", True

For Each OA_MailItem In OA_Folder.Items
If OA_MailItem Like "Chapter Downloaded" Then
Dim OrderInfo As Variant

OrderInfo = GrabInfo(OA_MailItem.Body)

If IsArray(OrderInfo) Then
ws.Range(Cells(NextRecord, 1), Cells(NextRecord, 5)) = OrderInfo
NextRecord = NextRecord + 1
End If
End If
Next

If Created Then OutlookApp.Quit

Application.ScreenUpdating = True

Set OA_Folder = Nothing
Set OA_NameSpace = Nothing
Set OutlookApp = Nothing
End Sub

Private Function GrabInfo(message As String) As Variant
Dim tmpInfo(4) As String

Dim f As Integer

Const TMPFILE As String = "C:\Temp\outlook_extraction.tmp"

If message = vbNullString Then GrabInfo = vbNullString: Exit Function

f = FreeFile

Open TMPFILE For Output As #f
Write #f, message
Close #f

f = FreeFile

Open TMPFILE For Input As #f

Do While Not EOF(f)
Dim tmpLine As String

Line Input #f, tmpLine

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, ":")

End Select
End If
Loop

Close #f

Kill TMPFILE

GrabInfo = tmpInfo
End Function

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

End Function

The line I seem to be having trouble with is boldened and in orange. I believe this is the line that will go to the specific folder I am trying to use in my outlook folders. Any help on how to set this to the folder I want would be very helpful.

 

[John_w]

Set OA_NameSpace = OutlookApp.GetNamespace("MAPI")
Set OA_Folder = OA_NameSpace.GetDefaultFolder(6)

The line I seem to be having trouble with is boldened and in orange. I believe this is the line that will go to the specific folder I am trying to use in my outlook folders. Any help on how to set this to the folder I want would be very helpful.

Try:

Set OA_Folder= OA_NameSpace.Folders("Personal Folders").Folders("SubfolderName")

'To go down further subfolders just append .Folders() to the level required:
Set OA_Folder= OA_NameSpace.Folders("Personal Folders").Folders("SubfolderName").Folders("Sub-subfolder")

Or to display Outlook's 'Select Folder' dialogue box and use the selected folder:

Set OA_Folder= OA_NameSpace.PickFolder

 

[scottluz]

I am trying to use one of the folders in my mailbox, that is not a subfolder. In my mailbox I have 25 folders, and the one I want is the 5th folder in the column. I have not done macros in a long time and just am stumped on this and why it will not grab the information I want.