Email List Save

Sub SaveEmailsWithAttachmentsList()

Dim outlookApp As Outlook.Application
Dim outlookNamespace As Outlook.Namespace
Dim inboxFolder As Outlook.MAPIFolder
Dim subFolder As Outlook.MAPIFolder
Dim mailItem As Outlook.MailItem
Dim attachmentCount As Long
Dim filePath As String
Dim emailData As String
Dim outputFile As Object
Dim folderQueue As Collection
Dim currentFolder As Outlook.MAPIFolder

' Initialize Outlook and set inbox
Set outlookApp = New Outlook.Application
Set outlookNamespace = outlookApp.GetNamespace("MAPI")
Set inboxFolder = outlookNamespace.GetDefaultFolder(olFolderInbox)

' Output file path (change to desired location)
filePath = "C:\EmailsWithAttachmentsList.csv"

' Initialize CSV output
emailData = "Subject,Sender,Received Date,Attachment Count,Folder Path" & vbNewLine

' Set up folder queue for recursive search
Set folderQueue = New Collection
folderQueue.Add inboxFolder

' Loop through all folders in the queue
While folderQueue.Count > 0
Set currentFolder = folderQueue(1)
folderQueue.Remove 1

' Check emails in current folder
For Each mailItem In currentFolder.Items
If mailItem.Class = olMail Then
attachmentCount = mailItem.Attachments.Count
If attachmentCount > 0 Then
emailData = emailData & """" & mailItem.Subject & """," _
& """" & mailItem.SenderName & """," _
& """" & mailItem.ReceivedTime & """," _
& attachmentCount & "," _
& """" & currentFolder.FolderPath & """" & vbNewLine
End If
End If
Next

' Add subfolders to the queue
For Each subFolder In currentFolder.Folders
folderQueue.Add subFolder
Next
Wend

' Write output to CSV
Set outputFile = CreateObject("Scripting.FileSystemObject").CreateTextFile(filePath, True)
outputFile.Write emailData
outputFile.Close

' Clean up
Set outputFile = Nothing
Set outlookApp = Nothing
Set outlookNamespace = Nothing
Set inboxFolder = Nothing
Set folderQueue = Nothing

MsgBox "Emails with attachments list saved to: " & filePath, vbInformation

End Sub