Go Premium for a chance to win a PS4. Enter to Win

x
?
Solved

VBA Code to Read "Header" Info

Posted on 2014-04-21
3
Medium Priority
?
1,117 Views
Last Modified: 2014-04-22
I need one-time code that will read "From", "Subject" and "Date Received" from all messages in a specific folder in a local Outlook mailbox. The folder from which I wish to extract the data is "BAC\Summaries\Success" under the root, which is my email address (if that matters). This is a private OST file, not public folders.

As I indicated, this will be a one-time run, so I can create a temporary sub and run it through debug. The output desired would be a comma-delimited csv file.
0
Comment
Question by:dbbishop
  • 2
3 Comments
 
LVL 76

Accepted Solution

by:
David Lee earned 2000 total points
ID: 40014490
Hi, dbbishop.  

This should get the job done.  Once you've added the code to Outlook (let me know if you need instructions for doing that), select the folder you want to export from and run the macro ExportMessagesToExcel.

Sub ExportMessagesToExcel()
    Const xlCSV = 6
    Dim olkMsg As Object, _
        excApp As Object, _
        excWkb As Object, _
        excWks As Object, _
        intRow As Integer, _
        intVersion As Integer, _
        strFilename As String
    strFilename = InputBox("Enter a filename (including path) to save the exported messages to.", "Export Messages to Excel")
    If strFilename <> "" Then
        intVersion = GetOutlookVersion()
        Set excApp = CreateObject("Excel.Application")
        Set excWkb = excApp.Workbooks.Add()
        Set excWks = excWkb.ActiveSheet
        'Write Excel Column Headers
        With excWks
            .Cells(1, 1) = "Sender"
            .Cells(1, 2) = "Subject"
            .Cells(1, 3) = "Received"
        End With
        intRow = 2
        'Write messages to spreadsheet
        For Each olkMsg In Application.ActiveExplorer.CurrentFolder.Items
            'Only export messages, not receipts or appointment requests, etc.
            If olkMsg.Class = olMail Then
                'Add a row for each field in the message you want to export
                excWks.Cells(intRow, 1) = olkMsg.Subject
                excWks.Cells(intRow, 2) = olkMsg.ReceivedTime
                excWks.Cells(intRow, 3) = GetSMTPAddress(olkMsg, intVersion)
                intRow = intRow + 1
            End If
        Next
        Set olkMsg = Nothing
        excApp.DisplayAlerts = False
        excWkb.SaveAs strFil, xlCSV
        excApp.DisplayAlerts = True
        excWkb.Close False
    End If
    Set excWks = Nothing
    Set excWkb = Nothing
    Set excApp = Nothing
    MsgBox "Process complete.  A total of " & intRow - 2 & " messages were exported.", vbInformation + vbOKOnly, "Export messages to Excel"
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

Function GetOutlookVersion() As Integer
    Dim arrVer As Variant
    arrVer = Split(Outlook.VERSION, ".")
    GetOutlookVersion = arrVer(0)
End Function

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

Open in new window

0
 
LVL 15

Author Closing Comment

by:dbbishop
ID: 40015541
Only change I had to make was in the SaveAs line. You'd entered strFil and it should have been strFilename. I also had to change the order of loading the cells, as the header didn't match up with the data. No big deal. Works like a champ.

Since I was going to open the file in Excel anyway, I changed the FileFormat from CVS to Excel.

Thank you very much!
0
 
LVL 76

Expert Comment

by:David Lee
ID: 40015618
You're welcome!
0

Featured Post

Keep up with what's happening at Experts Exchange!

Sign up to receive Decoded, a new monthly digest with product updates, feature release info, continuing education opportunities, and more.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

In this article I discuss my selections of the Top Four free Outlook OST File Viewers available. Open, view and read even damaged OST files by using these tools. They all provide a clear preview of all data such as emails, notes, tasks, calendars, e…
There can be many situations demanding the conversion of Outlook OST files to PST format and as such, there is no shortage of automated tools to perform this conversion. However, what makes Stellar OST to PST converter stand above the rest? Let us e…
Many of my clients call in with monstrous Gmail overloading issues with Outlook. A quick tip is to turn off the All Mail and Important folders from synching. Here is a quick video I made to show you how to turn off these and other folders in Gmail s…
A short tutorial showing how to set up an email signature in Outlook on the Web (previously known as OWA). For free email signatures designs, visit https://www.mail-signatures.com/articles/signature-templates/?sts=6651 If you want to manage em…

886 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question