Help with recursing through Mail sub folders and exporting to Excel

[OTPM]

Hi
I am struggling with trying to working out the code to extract mails from a designated Mailbox and Inbox together with all mails from each subfolder. The code I have works well with each individual folder but I have been struggling to find something I can add to my code the work through each sub-folder as well. I also want to specify a particular Mailbox and Inbox within the code. My current code is shown below and any help would be appreciated:

Option Explicit
Sub RMGpEmailExport()
Dim xlApp As Object
Dim xlWb As Object
Dim xlSheet As Object
Dim rCount As Long
Dim bXStarted As Boolean
Dim enviro As String
Dim strPath As String
Dim olApp As Outlook.Application
Dim olSession As Outlook.NameSpace
Dim olStartFolder As Outlook.MAPIFolder
Dim mailitems As Outlook.Items
Dim currentExplorer As Explorer
Dim Selection As Selection
Dim olItem As Outlook.mailItem
Dim obj As Object
Dim strColA, strColB, strColC, strColD, strColE, strColF, strColG, strColH, strColI, StrColJ, StrColK, StrColL, StrColM, StrColN, StrColO, StrColP, StrColQ As String
Dim LDate As Date
Dim propertyAccessor As Outlook.propertyAccessor
Dim PropName As String
Dim LVE As String
Dim LVET As String 'Date
Dim dtUTC As Date
Dim dtLocal As Date
Dim v As Variant
Dim strType As String
Dim olRecip As Recipient

Set olApp = New Outlook.Application
Set olSession = olApp.GetNamespace("MAPI")
Set olStartFolder = olSession.PickFolder
Set mailitems = olStartFolder.Items

' Get Excel set up
'enviro = CStr(Environ("USERPROFILE"))
'the path of the workbook
strPath = "D:\Email Metrics\RM Group\test.xlsx"
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err <> 0 Then
Application.StatusBar = "Please wait while Excel source is opened ... "
Set xlApp = CreateObject("Excel.Application")
bXStarted = True
End If
On Error GoTo 0
'Open the workbook to input the data
Set xlWb = xlApp.Workbooks.Open(strPath)
Set xlSheet = xlWb.Sheets("RMGpRawData")
' Process the message record

On Error Resume Next
'Find the next empty line of the worksheet
'Range(coltoSearch & Rows.count).End(xlUp).Row
Dim NextRow As Integer
rCount = xlSheet.Range("A100000").End(xlUp).Row + 1

' get the values from outlook
Set currentExplorer = Application.ActiveExplorer
Set Selection = currentExplorer.Selection
For Each obj In Selection
Set olItem = obj
If olItem <> "nothing" Then
'collect the fields
strColA = olItem.SenderName
strColB = olItem.CreationTime
strColC = olItem.To
strColD = olItem.Recipients
strColE = olItem.ReceivedByName
strColF = olItem.SentOn
strColG = olItem.ReceivedTime
strColH = olItem.UnRead
strColI = olItem.LastModificationTime
StrColJ = olItem.UserProperties
StrColK = olItem.Categories


'PR_LAST_VERB_EXECUTED
'URL LINKS REMOVED TO ALLOW ME TO POST.................................
'Obtain an instance of PropertyAccessor class
Set propertyAccessor = olItem.propertyAccessor
'Call GetProperty
LVE = propertyAccessor.GetProperty(LVE)
StrColL = LVE
'PR_LAST_VERB_EXECUTED_TIME
'URL LINKS REMOVED TO ALLOW ME TO POST.................................................
'Obtain an instance of PropertyAccessor class
Set propertyAccessor = olItem.propertyAccessor
'Call GetProperty
v = propertyAccessor.GetProperty(LVET)
'LVET = propertyAccessor.GetProperty(LVET)
StrColM = v
StrColN = olItem.ConversationID
StrColO = olItem.ConversationIndex
StrColP = olItem.ConversationTopic
StrColQ = olRecip.Type

'Add column Headers to the Excel Extract
xlSheet.Range("A" & 1) = "Sender Name"
xlSheet.Range("B" & 1) = "Creation Time"
xlSheet.Range("C" & 1) = "Sent To"
xlSheet.Range("D" & 1) = "Recipients"
xlSheet.Range("E" & 1) = "Received By Name"
xlSheet.Range("F" & 1) = "Sent On"
xlSheet.Range("G" & 1) = "Received Time"
xlSheet.Range("H" & 1) = "UnRead"
xlSheet.Range("I" & 1) = "Last Modification Time"
xlSheet.Range("J" & 1) = "User Properties"
xlSheet.Range("K" & 1) = "Categories"
xlSheet.Range("L" & 1) = "Last Verb Executed"
xlSheet.Range("M" & 1) = "Last Verb Executed Time"
xlSheet.Range("N" & 1) = "Conversation ID"
xlSheet.Range("O" & 1) = "Conversation Index"
xlSheet.Range("P" & 1) = "Conversation Topic"
xlSheet.Range("Q" & 1) = "Recipient Type"


'write them in the excel sheet
xlSheet.Range("A" & rCount) = strColA
xlSheet.Range("B" & rCount) = strColB
xlSheet.Range("C" & rCount) = strColC
xlSheet.Range("D" & rCount) = strColD
xlSheet.Range("E" & rCount) = strColE
xlSheet.Range("F" & rCount) = strColF
xlSheet.Range("G" & rCount) = strColG
xlSheet.Range("H" & rCount) = strColH
xlSheet.Range("I" & rCount) = strColI
xlSheet.Range("J" & rCount) = StrColJ
xlSheet.Range("K" & rCount) = StrColK
xlSheet.Range("L" & rCount) = StrColL
xlSheet.Range("M" & rCount) = StrColM
xlSheet.Range("N" & rCount) = StrColN
xlSheet.Range("O" & rCount) = StrColO
xlSheet.Range("P" & rCount) = StrColP
xlSheet.Range("Q" & rCount) = StrColQ

'Next row
rCount = rCount + 1
End If
Next

xlWb.Save

xlWb.Close 1
If bXStarted Then
xlApp.Quit
End If

Set olItem = Nothing
Set obj = Nothing
Set currentExplorer = Nothing
Set xlApp = Nothing
Set xlWb = Nothing
Set xlSheet = Nothing

MsgBox ("All RM Group Emails exported to Excel..........")
End Sub

[gmayor]

I didn't explore your various properties but concentrated on the folder handling. You will need something like the following, which includes code to create the named file (and the folder) if not present.


Option Explicit

Sub RMGpEmailExport()
Dim xlApp As Object
Dim xlWb As Object
Dim xlSheet As Object
Dim rCount As Long
Dim bXStarted As Boolean
Dim cFolders As Collection
Dim olFolder As Folder
Dim subFolder As Folder
Dim olNS As NameSpace
Dim strPath As String

strPath = "D:\Email Metrics\RM Group\test.xlsx"

On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err <> 0 Then
Set xlApp = CreateObject("Excel.Application")
bXStarted = True
End If
On Error GoTo 0

CreateFolders "D:\Email Metrics\RM Group\"
If FileExists(strPath) Then
Set xlWb = xlApp.workbooks.Open(strPath)
Set xlSheet = xlWb.sheets("RMGpRawData")
Else
Set xlWb = xlApp.workbooks.Add
xlWb.sheets(1).Name = "RMGpRawData"
Set xlSheet = xlWb.sheets("RMGpRawData")
'Add column Headers
With xlSheet
.Range("A" & 1) = "Sender Name"
.Range("B" & 1) = "Creation Time"
.Range("C" & 1) = "Sent To"
.Range("D" & 1) = "Recipients"
.Range("E" & 1) = "Received By Name"
.Range("F" & 1) = "Sent On"
.Range("G" & 1) = "Received Time"
.Range("H" & 1) = "UnRead"
.Range("I" & 1) = "Last Modification Time"
.Range("J" & 1) = "User Properties"
.Range("K" & 1) = "Categories"
.Range("L" & 1) = "Last Verb Executed"
.Range("M" & 1) = "Last Verb Executed Time"
.Range("N" & 1) = "Conversation ID"
.Range("O" & 1) = "Conversation Index"
.Range("P" & 1) = "Conversation Topic"
.Range("Q" & 1) = "Recipient Type"
End With
xlWb.SaveAs strPath
End If

Set cFolders = New Collection
Set olNS = GetNamespace("MAPI")
On Error GoTo lbl_Exit
cFolders.Add olNS.PickFolder
Do While cFolders.Count > 0
Set olFolder = cFolders(1)
cFolders.Remove 1
ProcessFolder olFolder, xlSheet
For Each subFolder In olFolder.folders
cFolders.Add subFolder
Next subFolder
Loop
xlWb.Save
xlWb.Close
If bXStarted Then xlApp.Quit
MsgBox ("All RM Group Emails exported to Excel..........")

lbl_Exit:
Set xlApp = Nothing
Set xlWb = Nothing
Set xlSheet = Nothing
Set olNS = Nothing
Exit Sub
End Sub

Sub ProcessFolder(iFolder As Folder, xlSheet As Object)
Dim i As Long
Dim olItem As Outlook.MailItem
Dim vSubject As Variant
Dim NextRow As Long
Dim strColA As String, strColB As String, strColC As String, strColD As String
Dim strColE As String, strColF As String, strColG As String, strColH As String
Dim strColI As String, StrColJ As String, StrColK As String, StrColL As String
Dim StrColM As String, StrColN As String, StrColO As String, StrColP As String, StrColQ As String
Dim propertyAccessor As Outlook.propertyAccessor
Dim PropName As String
Dim LVE As String
Dim LVET As String
Dim v As Variant
Dim olRecip As Recipient

MsgBox iFolder
On Error Resume Next
If iFolder.Items.Count > 0 Then
For i = 1 To iFolder.Items.Count
NextRow = xlSheet.Range("A" & xlSheet.Rows.Count).End(-4162).Row + 1
Set olItem = iFolder.Items(i)
strColA = olItem.SenderName
strColB = olItem.CreationTime
strColC = olItem.To
strColD = olItem.Recipients
strColE = olItem.ReceivedByName
strColF = olItem.SentOn
strColG = olItem.ReceivedTime
strColH = olItem.UnRead
strColI = olItem.LastModificationTime
StrColJ = olItem.UserProperties
StrColK = olItem.Categories
Set propertyAccessor = olItem.propertyAccessor
LVE = propertyAccessor.GetProperty(LVE)
StrColL = LVE
Set propertyAccessor = olItem.propertyAccessor
v = propertyAccessor.GetProperty(LVET)
StrColM = v
StrColN = olItem.ConversationID
StrColO = olItem.ConversationIndex
StrColP = olItem.ConversationTopic
StrColQ = olRecip.Type '?
xlSheet.Range("A" & NextRow) = strColA
xlSheet.Range("B" & NextRow) = strColB
xlSheet.Range("C" & NextRow) = strColC
xlSheet.Range("D" & NextRow) = strColD
xlSheet.Range("E" & NextRow) = strColE
xlSheet.Range("F" & NextRow) = strColF
xlSheet.Range("G" & NextRow) = strColG
xlSheet.Range("H" & NextRow) = strColH
xlSheet.Range("I" & NextRow) = strColI
xlSheet.Range("J" & NextRow) = StrColJ
xlSheet.Range("K" & NextRow) = StrColK
xlSheet.Range("L" & NextRow) = StrColL
xlSheet.Range("M" & NextRow) = StrColM
xlSheet.Range("N" & NextRow) = StrColN
xlSheet.Range("O" & NextRow) = StrColO
xlSheet.Range("P" & NextRow) = StrColP
xlSheet.Range("Q" & NextRow) = StrColQ
NextRow = NextRow + 1
DoEvents
Next i
End If
lbl_Exit:
Exit Sub
End Sub

Private Function FileExists(filespec) As Boolean
'An Outlook macro by Graham Mayor
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists(filespec) Then
FileExists = True
Else
FileExists = False
End If
lbl_Exit:
Exit Function
End Function

Private Function FolderExists(fldr) As Boolean
'An Outlook macro by Graham Mayor
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
If (fso.FolderExists(fldr)) Then
FolderExists = True
Else
FolderExists = False
End If
lbl_Exit:
Exit Function
End Function

Private Function CreateFolders(strPath As String)
'An Outlook macro by Graham Mayor
Dim strTempPath As String
Dim lngPath As Long
Dim vPath As Variant
vPath = Split(strPath, "\")
strPath = vPath(0) & "\"
For lngPath = 1 To UBound(vPath)
strPath = strPath & vPath(lngPath) & "\"
If Not FolderExists(strPath) Then MkDir strPath
Next lngPath
lbl_Exit:
Exit Function
End Function

[OTPM]

Hi Graham
Many thanks for taking the time to resolve my problem. It is really appreciated, it works perfectly and exactly as I wanted.
Again many thanks for your time and patience.
Kind regards
Tony

[OTPM]

Hi Graham
I have one final query "I think" :-).
For some reason when I run the extract on each Mailbox it always misses week 45 out of the extract. I cannot see anything in your code that would cause this to happen. Do you have any ideas/pointers as to why this may be happening?
Thanks
Tony

Update: I have found the issue causing the above. All dates are being out in the format mm/dd/yyyy. How do I get the extract to output in the format dd/mm/yyyy please.
Thanks
Tony

[gmayor]

If you change the string variables that reflect dates e.g. strColB As String to date variables e.g. dColB As Date, you should get the correct dates when inserted into Excel