exporting Attachment File names from outlook to Excel

Question

I tried to make a code that exports email attachment file names from Outlook to excel. The issue I am having some of my attachments are coming up blank. Is there a way I can adjust the VBA where I can pull all types of attachments file names. The PDF that are showing blank are usually sent by our system but not sure why they are blank. I have tried to adjust the olkMsg.Attachments to other codes but they are not working.

Please see the code below:

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"
            .Cells(1, 4) = "Subject"
            .Cells(1, 5) = "Recipent"
            .Cells(1, 6) = "CC"
        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)
                excWks.Cells(intRow, 4) = olkMsg.Subject
                excWks.Cells(intRow, 5) = olkMsg.To
                excWks.Cells(intRow, 6) = olkMsg.CC
                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

Eugene Astafiev · Answer

It makes sense to check the Attachment.Type property in that case. It returns an OlAttachmentType constant indicating the type of the specified object. Be aware that files uploaded to OneDrive are sent using link files.

Also instead of iterating over all items in the folder and checking for some conditions met:

 For Each olkMsg In Application.ActiveExplorer.CurrentFolder.Items
            'Only export messages, not receipts or appointment requests, etc.
            If olkMsg.Class = olMail Then

You can use the Find/FindNext or Restrict methods of the Items class. They allow getting items that correspond to the predefined criteria, so you could iterate over all mail items with attachments in the folder. Read more about these methods in the articles I wrote for the technical blog:

exporting Attachment File names from outlook to Excel

1 Answers