Const MACRO_NAME = "Export Messages to Excel" Dim excApp As Object, _ excWkb As Object, _ excWks As Object, _ intVer As Integer, _ intCnt As Integer Sub ExportMessagesToExcel() Dim strFil As String On Error Resume Next Set WshShell = CreateObject("WScript.Shell") strDocuments = WshShell.SpecialFolders("MyDocuments") 'strFil = InputBox("Enter a filename (including path) to save the exported messages to.", MACRO_NAME) Todays_Date = Date 'REPLACE FWD FLASHES WITH DASHES Todays_Date_1 = Replace(Todays_Date, "/", "-") strFil = strDocuments & "\Outlook_Email_Export_" & Todays_Date_1 If strFil <> "" Then intCnt = 0 intVer = GetOutlookVersion() Set excApp = CreateObject("Excel.Application") Set excWkb = excApp.Workbooks.Add Set excWks = excWkb.Worksheets(1) 'Write Excel Column Headers With excWks .Cells(1, 1) = "Subject" .Cells(1, 2) = "Date" .Cells(1, 3) = "From" .Cells(1, 4) = "To" .Cells(1, 5) = "Attachment" .Cells(1, 6) = "CC" .Cells(1, 7) = "Body" .Cells(1, 8) = "Header" End With ProcessFolder Application.ActiveExplorer.CurrentFolder excWks.Columns("A:I").AutoFit 'SEE IF FILE ALREADY EXISTS Set WshShell = CreateObject("WScript.Shell") strDocuments = WshShell.SpecialFolders("MyDocuments") Todays_Date = Date Todays_Date_1 = Replace(Todays_Date, "/", "-") strFil = strDocuments & "\Outlook_Email_Export_" & Todays_Date_1 & ".xlsx" thesentence = strFil 'FILE EXISTS - PROMPT USER FOR FILENAME If Dir(thesentence) <> "" Then strFil_0 = InputBox("Enter a filename to save the exported messages to (e.g. Email_Export).", MACRO_NAME) strFil = strDocuments & "\" & strFil_0 & ".xlsx" excWkb.SaveAs strFil MsgBox "Process complete. A total of " & intCnt & " messages were exported to your Documents folder.", vbInformation + vbOKOnly, MACRO_NAME 'FILE DNE -> PROCEED WITH SAVE USING "Outlook_Email_Export_" & today's date FORMAT Else excWkb.SaveAs strFil MsgBox "Process complete. A total of " & intCnt & " messages were exported to your Documents folder (filename: Outlook_Email_Export_[today's date]).", vbInformation + vbOKOnly, MACRO_NAME End If End If Set excWks = Nothing Set excWkb = Nothing excApp.Quit Set excApp = Nothing End Sub Private Sub ProcessFolder(olkFld As Outlook.MAPIFolder) Dim olkMsg As Object, _ olkAtt As Object, _ olkSub As Object, _ intRow As Integer, _ strAtt As String intRow = excWks.UsedRange.Rows.Count intRow = intRow + 1 'Write messages to spreadsheet For Each olkMsg In olkFld.Items 'Only export messages, not receipts or appointment requests, etc. If olkMsg.Class = olMail Then 'Get the names of all attachments strAtt = "" For Each olkAtt In olkMsg.Attachments If Not IsHiddenAttachment(olkAtt) And olkAtt.Type <> olOLE Then strAtt = strAtt & olkAtt.FileName & ", " End If Next If Len(strAtt) > 0 Then strAtt = Left(strAtt, Len(strAtt) - 2) End If 'Add a row for each field in the message you want to export With excWks .Cells(intRow, 1) = olkMsg.Subject .Cells(intRow, 2) = olkMsg.ReceivedTime .Cells(intRow, 3) = GetSMTPAddress(olkMsg, intVer) .Cells(intRow, 4) = olkMsg.To .Cells(intRow, 5) = strAtt .Cells(intRow, 6) = olkMsg.CC .Cells(intRow, 7) = olkMsg.Body 'TRIM COL 7 (NOT ONLY OF SPACES BUT ALSO CARRIAGE RETURN SYMBOLS) FormBody = Cells(intRow, 7).Value FormBody1 = Replace(FormBody, vbCrLf, " ") FormBody2 = Replace(FormBody1, vbCr, " ") FormBody3 = Replace(FormBody2, vbLf, " ") FormBody4 = Trim(FormBody3) FormBody5 = tidyspaces("" & FormBody4) Cells(intRow, 7).Value = FormBody5 .Cells(intRow, 8) = GetInetHeaders(olkMsg) End With intRow = intRow + 1 intCnt = intCnt + 1 End If Next Set olkMsg = Nothing For Each olkSub In olkFld.Folders ProcessFolder olkSub Next Set olkSub = Nothing Set olkMsg = Nothing Set olkAtt = Nothing End Sub Private Function GetSMTPAddress(Item As Outlook.MailItem, intOutlookVersion As Integer) As String Dim olkSnd As Outlook.AddressEntry, olkEnt As Object On Error Resume Next Select Case intOutlookVersion Case Is < 14 If Item.SenderEmailType = "EX" Then GetSMTPAddress = SMTP2007(Item) Else GetSMTPAddress = Item.SenderEmailAddress End If Case Else Set olkSnd = Item.Sender If olkSnd.AddressEntryUserType = olExchangeUserAddressEntry Then Set olkEnt = olkSnd.GetExchangeUser GetSMTPAddress = olkEnt.PrimarySmtpAddress Else GetSMTPAddress = Item.SenderEmailAddress End If End Select On Error GoTo 0 Set olkPrp = Nothing Set olkSnd = Nothing Set olkEnt = Nothing End Function Private Function GetOutlookVersion() As Integer Dim arrVer As Variant arrVer = Split(Outlook.Version, ".") GetOutlookVersion = arrVer(0) End Function Private Function SMTP2007(olkMsg As Outlook.MailItem) As String Dim olkPA As Outlook.PropertyAccessor On Error Resume Next Set olkPA = olkMsg.PropertyAccessor SMTP2007 = olkPA.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x5D01001E") On Error GoTo 0 Set olkPA = Nothing End Function Private Function GetInetHeaders(olkMsg As Outlook.MailItem) As String ' Purpose: Returns the internet headers of a message. Const PR_TRANSPORT_MESSAGE_HEADERS = "http://schemas.microsoft.com/mapi/proptag/0x007D001E" Dim olkPA As Outlook.PropertyAccessor Set olkPA = olkMsg.PropertyAccessor GetInetHeaders = olkPA.GetProperty(PR_TRANSPORT_MESSAGE_HEADERS) Set olkPA = Nothing End Function Private Function IsHiddenAttachment(olkAtt As Outlook.Attachment) As Boolean ' Purpose: Determines if an attachment is a hidden attachment. Const PR_ATTACH_CONTENT_ID = "http://schemas.microsoft.com/mapi/proptag/0x3712001E" Dim olkPA As Outlook.PropertyAccessor, varTemp As Variant On Error Resume Next Set olkPA = olkAtt.PropertyAccessor varTemp = olkPA.GetProperty(PR_ATTACH_CONTENT_ID) IsHiddenAttachment = (varTemp <> "") On Error GoTo 0 Set olkPA = Nothing End Function Function tidyspaces(s As String) As String While InStr(s, " ") > 0 s = Replace(s, " ", " ") Wend tidyspaces = s End Function