Metadata exporter for Outlook .msg files

msg_metadata.bas

Sub GetMessages()
  readdir "folder_location"
End Sub

Sub readdir(folderName As String)
  Dim fs As Scripting.FileSystemObject
  Dim folder As Scripting.folder
  Dim file As Scripting.file
  Dim message As Object
  
  Dim Excel As Object
  Set Excel = CreateObject("Excel.Application")
  Dim workbook As Object
  Set workbook = Excel.Workbooks.Add
  Dim sheet As Object
  Set sheet = workbook.ActiveSheet
  Dim rowNum As Integer
    
  Set fs = New Scripting.FileSystemObject
  Set folder = fs.GetFolder(folderName)
  
  outputPath = "output_file.csv"
  
  If fs.FileExists(outputPath) Then
    fs.DeleteFile outputPath
  End If
  
  sheet.Cells(1, 1) = "Subject"
  sheet.Cells(1, 2) = "Sender"
  sheet.Cells(1, 3) = "Address"
  sheet.Cells(1, 4) = "Sent"
  sheet.Cells(1, 5) = "Recipients"
  
  rowNum = 2
  
  For Each file In folder.Files
    Set message = Application.Session.OpenSharedItem(file.Path)
    ' Set message = Application.CreateItemFromTemplate(file.Path)
    ' Debug.Print message
    
    sheet.Cells(rowNum, 1) = message.Subject
    sheet.Cells(rowNum, 2) = message.SenderName
    sheet.Cells(rowNum, 3) = message.SenderEmailAddress
    sheet.Cells(rowNum, 4) = message.SentOn
    
    Dim recipients() As String
    ReDim recipients(1 To message.recipients.Count) As String
    
    For i = 1 To message.recipients.Count
      recipients(i) = message.recipients.Item(i).Name
    Next i
    
    sheet.Cells(rowNum, 5) = Join(recipients, ";")
    rowNum = rowNum + 1
  Next file
  
  sheet.SaveAs FileName:=outputPath, FileFormat:=6
  workbook.Saved = True
  
  Excel.Quit
  Set Excel = Nothing
End Sub