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.
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.