VBA code to extract metadata from .msg files
SEE AN UPDATE FOR THIS TIP HERE: https://www.litigationsupporttipofthenight.com/single-post/troubleshooting-vba-error-on-code-to-extract-msg-file-metadata
If you have a set of .msg files you can extract the metadata from the files using the below VBA code, posted here.
First begin, by opening Visual Basic and selecting the Microsoft Object Library in Tools . . .. References
In the vba code enter the path for the folder which contains the .msg files.
After you run the subject; author; recipient; copyee; and date fields will be extracted to separate columns in a worksheet.
Sub GetMailInfo()
Dim MyOutlook As Outlook.Application Dim msg As Outlook.MailItem Dim x As Namespace Dim Path As String Dim i As Long
Set MyOutlook = New Outlook.Application Set x = MyOutlook.GetNamespace("MAPI") Path = "C:\FooFolder\email\" FileList = GetFileList(Path + "*.msg")
Row = 1
While Row <= UBound(FileList)
Set msg = x.OpenSharedItem(Path + FileList(Row))
Cells(Row + 1, 1) = msg.Subject Cells(Row + 1, 2) = msg.Sender Cells(Row + 1, 3) = msg.CC Cells(Row + 1, 4) = msg.To Cells(Row + 1, 5) = msg.SentOn If msg.Attachments.Count > 0 Then For i = 1 To msg.Attachments.Count Cells(Row + 1, 5 + i) = msg.Attachments.Item(i).FileName Next i End If
Row = Row + 1 Wend
End Sub Function GetFileList(FileSpec As String) As Variant ' Taken from http://spreadsheetpage.com/index.php/tip/getting_a_list_of_file_names_using_vba/ ' Returns an array of filenames that match FileSpec ' If no matching files are found, it returns False
Dim FileArray() As Variant Dim FileCount As Integer Dim FileName As String
On Error GoTo NoFilesFound
FileCount = 0 FileName = Dir(FileSpec) If FileName = "" Then GoTo NoFilesFound
' Loop until no more matching files are found Do While FileName <> "" FileCount = FileCount + 1 ReDim Preserve FileArray(1 To FileCount) FileArray(FileCount) = FileName FileName = Dir() Loop GetFileList = FileArray Exit Function
' Error handler NoFilesFound: GetFileList = False End Function