Macro for recording the attachment name into Excel from Outlook

[prazad82]

Hello,

I somehow managed to get a code that extracts the details of email into an excel sheet (Appended is the code). I need to get the name of the attachments as well in the resulting excel sheet (or extracting any other field to excel)

Sub ExportMessagesToExcel()
Dim olkMsg As Object, _excApp As Object, _excWkb As Object, _excWks As Object, _intRow As Integer, _intVersion As Integer, _strFilename As StringstrFilename = InputBox("Enter a filename (including path) to save the exported messages to.", "Export Messages to Excel")If strFilename <> "" ThenintVersion = GetOutlookVersion()Set excApp = CreateObject("Excel.Application")Set excWkb = excApp.Workbooks.Add()Set excWks = excWkb.ActiveSheet'Write Excel Column HeadersWith excWks.Cells(1, 1) = "Subject".Cells(1, 2) = "Received".Cells(1, 3) = "Sender"End WithintRow = 2'Write messages to spreadsheetFor 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 exportexcWks.Cells(intRow, 1) = olkMsg.SubjectexcWks.Cells(intRow, 2) = olkMsg.ReceivedTimeexcWks.Cells(intRow, 3) = GetSMTPAddress(olkMsg, intVersion)intRow = intRow + 1End IfNextSet olkMsg = NothingexcWkb.SaveAs strFilenameexcWkb.CloseEnd IfSet excWks = NothingSet 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

Any help is appreciated.

 

[prazad82]

Finally, I got the code working! This code is only compatible with 2007. How do I get this running for other versions as well???

Here is the code:

Const MACRO_NAME = "Export Messages to Excel (Rev 5)"

Sub ExportMessagesToExcel()
    Dim olkMsg As Object, _
        olkAtt As Outlook.Attachment, _
        excApp As Object, _
        excWkb As Object, _
        excWks As Object, _
        intRow As Integer, _
        intVersion As Integer, _
        strFilename As String, _
        strAtt As String
    strFilename = InputBox("Enter a filename (including path) to save the exported messages to.", MACRO_NAME)
    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) = "Received"
            .cells(1, 2) = "Sender"
            .cells(1, 3) = "Attachments"
        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.ReceivedTime
                excWks.cells(intRow, 2) = GetSMTPAddress(olkMsg, intVersion)
                strAtt = ""
                For Each olkAtt In olkMsg.Attachments
                    If Not IsHiddenAttachment(olkAtt) Then
                        strAtt = strAtt & olkAtt.FileName & ", "
                    End If
                Next
                If strAtt <> "" Then
                    strAtt = Left(strAtt, Len(strAtt) - 2)
                End If
                excWks.cells(intRow, 3) = strAtt
                intRow = intRow + 1
            End If
        Next
        Set olkMsg = Nothing
        excWkb.SaveAs strFilename
        excWkb.Close
    End If
    Set excWks = Nothing
    Set excWkb = Nothing
    Set excApp = Nothing
    MsgBox "Process complete.  A total of " & intRow - 2 & " messages were exported.", vbInformation + vbOKOnly, MACRO_NAME
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

Function IsHiddenAttachment(olkAtt As Outlook.Attachment) As Boolean
    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