VBA code to save multiple emails as text files

You can use the below visual basic code posted here on Slip Stick, to to convert multiple selected emails to separate text files. (Follow the link to 'SaveSelectedMailAsTxtFile.)

Enter your own file path in the code on the line beginning, oMail.SaveAs, for the folder in which you want the text files to be generated.

If you select multiple emails in an Outlook folder, and the run the macro . . .

. . . text files will be generated beginning the date and time of the emails.

Sub SaveSelectedMailAsTxtFile() Const OLTXT = 0 Dim currentExplorer As Explorer Dim Selection As Selection Dim oMail As Outlook.MailItem Dim obj As Object Dim sPath As String Dim dtDate As Date Dim sName As String

Set currentExplorer = Application.ActiveExplorer Set Selection = currentExplorer.Selection

For Each obj In Selection Set oMail = obj sName = oMail.Subject ReplaceCharsForFileName sName, "_" dtDate = oMail.ReceivedTime sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, _ vbUseSystem) & Format(dtDate, "-hhnnss", _ vbUseSystemDayOfWeek, vbUseSystem) & "-" & sName & ".txt" oMail.SaveAs "C:\Users\Diane\Dropbox\For EMO\" & sName, OLTXT Next End Sub Private Sub ReplaceCharsForFileName(sName As String, _ sChr As String _ ) sName = Replace(sName, "/", sChr) sName = Replace(sName, "\", sChr) sName = Replace(sName, ":", sChr) sName = Replace(sName, "?", sChr) sName = Replace(sName, Chr(34), sChr) sName = Replace(sName, "<", sChr) sName = Replace(sName, ">", sChr) sName = Replace(sName, "|", sChr) End Sub

VBA code to extract metadata from Outlook emails to Excel spreadsheet

The below VBA code is based on the code posted here by Troy Graham. You can use this code to select a folder in Outlook and export the sender; to; subject; senton; and conversationindex fields to an Excel spreadsheet.

Enter Visual Basic in Outlook and paste the code in a new module. Confirm that the Microsoft Excel object library is selected in References under the Tool menu.

The code requires that an Excel file be created at C:\excel named 'Emails.xlsx'. You can edit the code to alter the location of the file to which the metadata is exported.

When the code is run, you will be prompted to select a folder in your Outlook profile.

An Excel will be generated that will open automatically. It will have the Outlook metadata listed in separate columns.

You can change the Outlook fields referenced on lines such as:

rng.value = msg.ConversationIndex

. . . . to export other metadata.

Sub ExportToExcel()

On Error GoTo ErrHandler Dim appExcel As Excel.Application Dim wkb As Excel.Workbook Dim wks As Excel.Worksheet Dim rng As Excel.Range Dim strSheet As String Dim strPath As String Dim intRowCounter As Integer Dim intColumnCounter As Integer Dim msg As Outlook.MailItem Dim nms As Outlook.NameSpace Dim fld As Outlook.MAPIFolder

Dim itm As Object strSheet = "Emails.xlsx" strPath = "C:\excel\" strSheet = strPath & strSheet

Debug.Print strSheet ' Select export folder Set nms = Application.GetNamespace("MAPI") Set fld = nms.PickFolder

' Handle potential errors with Select Folder dialog box. If fld Is Nothing Then MsgBox "There are no mail messages to export", vbOKOnly, _ "Error"

Exit Sub ElseIf fld.DefaultItemType <> olMailItem Then MsgBox "There are no mail messages to export", vbOKOnly, _ "Error"

Exit Sub

ElseIf fld.Items.Count = 0 Then MsgBox "There are no mail messages to export", vbOKOnly, _ "Error" Exit Sub

End If ' Open and activate Excel workbook. Set appExcel = CreateObject("Excel.Application") appExcel.Workbooks.Open (strSheet)

Set wkb = appExcel.ActiveWorkbook Set wks = wkb.Sheets(1) wks.Activate appExcel.Application.Visible = True

' Copy field items in mail folder. For Each itm In fld.Items intColumnCounter = 1 Set msg = itm intRowCounter = intRowCounter + 1 Set rng = wks.Cells(intRowCounter, intColumnCounter) rng.value = msg.To intColumnCounter = intColumnCounter + 1

Set rng = wks.Cells(intRowCounter, intColumnCounter) rng.value = msg.SenderEmailAddress intColumnCounter = intColumnCounter + 1

Set rng = wks.Cells(intRowCounter, intColumnCounter)

rng.value = msg.Subject intColumnCounter = intColumnCounter + 1 Set rng = wks.Cells(intRowCounter, intColumnCounter) rng.value = msg.SentOn intColumnCounter = intColumnCounter + 1 Set rng = wks.Cells(intRowCounter, intColumnCounter) rng.value = msg.ConversationIndex

Next itm Set appExcel = Nothing Set wkb = Nothing Set wks = Nothing Set rng = Nothing Set msg = Nothing Set nms = Nothing Set fld = Nothing Set itm = Nothing

Exit Sub

ErrHandler: If Err.Number = 1004 Then MsgBox strSheet & " doesn't exist", vbOKOnly, _ "Error"

Else

MsgBox Err.Number & "; Description: ", vbOKOnly, _ "Error"

End If

Set appExcel = Nothing Set wkb = Nothing Set wks = Nothing Set rng = Nothing Set msg = Nothing Set nms = Nothing Set fld = Nothing Set itm = Nothing End Sub

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