I'm trying to create VBA that:
Have created the below but it only pulls one folder and then exits.
I was expecting the code to loop through all folders in my Inbox but it didn't
Sub ExportEmailsToExcel()
Dim outlookApp As Outlook.Application
Dim outlookNamespace As Outlook.Namespace
Dim folder As Outlook.MAPIFolder
Dim subfolder As Outlook.MAPIFolder
Dim item As Object
Dim mailItem As Outlook.mailItem
Dim xlApp As Object
Dim xlWorkbook As Object
Dim xlWorksheet As Object
Dim row As Integer
Set outlookApp = New Outlook.Application
Set outlookNamespace = outlookApp.GetNamespace("MAPI")
Set folder = outlookNamespace.Folders("example@outlook.com")
' Create a new Excel workbook
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
Set xlWorkbook = xlApp.Workbooks.Add
Set xlWorksheet = xlWorkbook.Sheets(1)
' Set up the header row in Excel
xlWorksheet.Cells(1, 1).Value = "Date Received"
xlWorksheet.Cells(1, 2).Value = "From"
xlWorksheet.Cells(1, 3).Value = "From Email Address"
xlWorksheet.Cells(1, 4).Value = "Subject"
xlWorksheet.Cells(1, 5).Value = "Email Folder Location"
xlWorksheet.Cells(1, 6).Value = "Has Attachments"
row = 2
' Loop through all subfolders
For Each subfolder In folder.Folders
For Each item In subfolder.Items
If TypeName(item) = "MailItem" Then
Set mailItem = item
If mailItem.SenderEmailAddress = "example@outlook.com" Then
xlWorksheet.Cells(row, 1).Value = mailItem.ReceivedTime
xlWorksheet.Cells(row, 2).Value = mailItem.SenderName
xlWorksheet.Cells(row, 3).Value = mailItem.SenderEmailAddress
xlWorksheet.Cells(row, 4).Value = mailItem.Subject
xlWorksheet.Cells(row, 5).Value = subfolder.FolderPath
xlWorksheet.Cells(row, 6).Value = IIf(mailItem.Attachments.Count > 0, "True", "False")
row = row + 1
End If
End If
Next item
Next subfolder
MsgBox "Export complete!", vbInformation
' Clean up
Set xlWorksheet = Nothing
Set xlWorkbook = Nothing
xlApp.Quit
Set xlApp = Nothing
Set folder = Nothing
Set outlookNamespace = Nothing
Set outlookApp = Nothing
End Sub
You need to loop though the folder just like you would do it for folders and subfolders in windows explorer. Also I do not see a Date check?
Is this what you are trying? I have commented the code. If you still have a quesiton, then simply ask.
PS: I have divided the entire process in two procedures. This way it is easier to understand and manage the code.
Option Explicit
Sub ExportEmailsToExcel()
Dim outlookApp As Outlook.Application
Dim outlookNamespace As Outlook.NameSpace
Dim rootFolder As Outlook.MAPIFolder
Dim xlApp As Object
Dim xlWorkbook As Object
Dim xlWorksheet As Object
Dim row As Long: row = 2 '<~~ Use Long and not Integer
Set outlookApp = New Outlook.Application
Set outlookNamespace = outlookApp.GetNamespace("MAPI")
Set rootFolder = outlookNamespace.Folders("example@outlook.com")
'~~> Create a new Excel workbook
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
Set xlWorkbook = xlApp.Workbooks.Add
Set xlWorksheet = xlWorkbook.Sheets(1)
'~~> Set up the header row in Excel
With xlWorksheet
.Cells(1, 1).Value = "Date Received"
.Cells(1, 2).Value = "From"
.Cells(1, 3).Value = "From Email Address"
.Cells(1, 4).Value = "Subject"
.Cells(1, 5).Value = "Email Folder Location"
.Cells(1, 6).Value = "Has Attachments"
End With
'~~> Loop through all folders and subfolders
ProcessFolder rootFolder, xlWorksheet, row
MsgBox "Export complete!", vbInformation
End Sub
'~~> Separate function for looping
Sub ProcessFolder(ByVal folder As Outlook.MAPIFolder, ByRef xlWorksheet As Object, ByRef row As Long)
Dim subfolder As Outlook.MAPIFolder
Dim item As Object
Dim mailItem As Outlook.mailItem
Dim dateLimit As Date
'~~> Check for last 30 days
dateLimit = DateAdd("d", -30, Now)
'~~> Loop
For Each item In folder.Items
If TypeName(item) = "MailItem" Then
Set mailItem = item
If mailItem.ReceivedTime >= dateLimit Then
xlWorksheet.Cells(row, 1).Value = mailItem.ReceivedTime
xlWorksheet.Cells(row, 2).Value = mailItem.SenderName
xlWorksheet.Cells(row, 3).Value = mailItem.SenderEmailAddress
xlWorksheet.Cells(row, 4).Value = mailItem.Subject
xlWorksheet.Cells(row, 5).Value = folder.FolderPath
xlWorksheet.Cells(row, 6).Value = IIf(mailItem.Attachments.Count > 0, "True", "False")
row = row + 1
End If
End If
Next item
'~~> Loop through sub folders if any
For Each subfolder In folder.Folders
ProcessFolder subfolder, xlWorksheet, row
Next subfolder
End Sub