Reputation: 159
I am scratching my head on this one, I am fairly new to VBA (and programming in general) and would like this code improved. Any ideas on how to cover all mail items in main folders, sub folders, sub sub folders with an improved or simplified code?
1 level down:
2 levels down:
3 levels down:
My code so far is:
Sub GetEmailsDetailsMINE()
Dim outlook_app As Outlook.Application
Dim namespace As Outlook.namespace
Set outlook_app = New Outlook.Application
Set namespace = outlook_app.GetNamespace("MAPI")
Dim account_folder As Outlook.MAPIFolder
Dim main_folder As Outlook.MAPIFolder
Dim sub_folder1 As Outlook.MAPIFolder
Dim sub_folder2 As Outlook.MAPIFolder
On Error Resume Next
Dim obj_mail As Outlook.MailItem
Dim rowNumber As Integer
rowNumber = 2
For Each account_folder In namespace.Folders
' main account, eg [email protected]
For Each main_folder In account_folder.Folders
' 1 level down, find emails here
For Each obj_item In main_folder.Items
If obj_item.Class = olMail Then
Set obj_mail = obj_item
Cells(rowNumber, 1) = obj_mail.SenderEmailAddress
Cells(rowNumber, 2) = obj_mail.To
Cells(rowNumber, 3) = obj_mail.Subject
Cells(rowNumber, 4) = obj_mail.ReceivedTime
Cells(rowNumber, 5) = obj_mail.EntryID
Cells(rowNumber, 6) = main_folder.Name
rowNumber = rowNumber + 1
End If
Next obj_item
For Each sub_folder1 In main_folder.Folders
' two levels down, find emails here
For Each obj_item In sub_folder1.Items
If obj_item.Class = olMail Then
Set obj_mail = obj_item
Cells(rowNumber, 1) = obj_mail.SenderEmailAddress
Cells(rowNumber, 2) = obj_mail.To
Cells(rowNumber, 3) = obj_mail.Subject
Cells(rowNumber, 4) = obj_mail.ReceivedTime
Cells(rowNumber, 5) = obj_mail.EntryID
Cells(rowNumber, 6) = sub_folder1.Name
rowNumber = rowNumber + 1
End If
Next obj_item
' three levels down
For Each sub_folder2 In sub_folder1.Folders
For Each obj_item In sub_folder2.Items
If obj_item.Class = olMail Then
Set obj_mail = obj_item
Cells(rowNumber, 1) = obj_mail.SenderEmailAddress
Cells(rowNumber, 2) = obj_mail.To
Cells(rowNumber, 3) = obj_mail.Subject
Cells(rowNumber, 4) = obj_mail.ReceivedTime
Cells(rowNumber, 5) = obj_mail.EntryID
Cells(rowNumber, 6) = sub_folder1.Name & " || " & sub_folder2.Name
rowNumber = rowNumber + 1
End If
Next obj_item
Next sub_folder2
Next sub_folder1
Next main_folder
Next account_folder
On Error GoTo 0
End Sub
This works fine, I can get all the items I want but somehow I find it repetitive. Any ideas on how to improve my code?
Upvotes: 1
Views: 1124
Reputation: 31
How about using recursion? Something like this ...
Sub GetEmailsDetails()
' Loop through all folders
Dim outlook_app As Outlook.Application
Dim namespace As Outlook.namespace
Set outlook_app = New Outlook.Application
Set namespace = outlook_app.GetNamespace("MAPI")
Dim main_folder As Outlook.MAPIFolder
'
On Error Resume Next
Dim obj_mail As Outlook.MailItem
Dim rowNumber As Integer
rowNumber = 1
For Each main_folder In namespace.Folders
EmailDetailsForSubfolder main_folder, rowNumber
Next main_folder
On Error GoTo 0
End Sub
Sub EmailDetailsForSubfolder(ThisFolder as Outlook.MAPIFolder, ByRef rowNumber as Integer)
Dim obj_mail As Outlook.MailItem
Dim sub_folder As Outlook.MAPIFolder
For Each obj_mail In ThisFolder.Items
If obj_item.Class = olMail Then
rowNumber = rowNumber + 1
Cells(rowNumber, 1) = obj_mail.SenderEmailAddress
Cells(rowNumber, 2) = obj_mail.To
Cells(rowNumber, 3) = obj_mail.Subject
Cells(rowNumber, 4) = obj_mail.ReceivedTime
Cells(rowNumber, 5) = obj_mail.EntryID
Cells(rowNumber, 6) = ThisFolder.Name
End If
Next obj_mail
For Each sub_folder In ThisFolder.Folders
EmailDetailsForSubfolder sub_folder, rowNumber
Next
End Sub
Upvotes: 1
Reputation: 166126
EDIT - tested/fixed
A non-recursive approach:
Sub GetEmailsDetails()
Dim outlook_app As Outlook.Application
Dim namespace As Outlook.namespace
Dim colFolders As New Collection
Dim fldr As Outlook.MAPIFolder, subfldr As Outlook.MAPIFolder
Dim obj_mail As Outlook.MailItem, obj_item
Dim rowNumber As Long
Set outlook_app = New Outlook.Application
Set namespace = outlook_app.GetNamespace("MAPI")
For Each fldr In namespace.Folders
For Each subfldr In fldr.Folders
colFolders.Add subfldr
Next subfldr
Next
rowNumber = 2
Do While colFolders.Count > 0
Set fldr = colFolders(1) 'get next folder to process
colFolders.Remove 1 'remove that item
Application.StatusBar = fldr.FolderPath
'process the folder
For Each obj_item In fldr.Items
If obj_item.Class = olMail Then
Set obj_mail = obj_item
Application.StatusBar = rowNumber & " - " & fldr.FolderPath
On Error Resume Next
Cells(rowNumber, 1).Resize(1, 6).Value = _
Array(obj_mail.SenderEmailAddress, obj_mail.To, _
obj_mail.Subject, obj_mail.ReceivedTime, _
obj_mail.EntryID, fldr.FolderPath)
On Error GoTo 0
rowNumber = rowNumber + 1
End If
Next obj_item
'store all subfolders for processing
For Each subfldr In fldr.Folders
colFolders.Add subfldr, before:=1
Next
Loop
Application.StatusBar = False
End Sub
Upvotes: 1