Saving Outlook Attachments - but not the inline images

Public Sub SaveAttachmentsToDisk(MItem As Outlook.MailItem, strFolderPath As String)
    Dim oAttachment As Outlook.attachment
    Dim sSaveFolder As String
    Dim fso As New Scripting.FileSystemObject
    Dim bName As String
    Dim sSaveFolder As String
    
    'Checking that path ends in \
    If Right(strFolderPath, 1) = "\" Then
        ' fall through
    Else:
        strFolderPath = strFolderPath & "\"
    End If
    
    sSaveFolder = strFolderPath
    
    For Each oAttachment In MItem.Attachments
        If oAttachment.Type <> olEmbeddeditem Then
            ' change the file name with the index
            'Debug.Print "DisplayName: " & oAttachment.DisplayName
            'Debug.Print "FileName: " & oAttachment.FileName
            'Debug.Print "Pathname: " & oAttachment.PathName
            ' get the filename (no extension)
            bName = fso.GetBaseName(oAttachment.DisplayName)
            ' rename the file with no extension using the index as the order
            ' to be merged at a future date
            bName = oAttachment.Index & "-" & bName
            ' put the extension back on
            bName = bName & "." & fso.GetExtensionName(oAttachment.DisplayName)
            ' save the file with the new name
            oAttachment.SaveAsFile sSaveFolder & bName
        End If
    Next
    
End Sub

Select allOpen in new window

Public 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" - original
    Const PR_ATTACH_CONTENT_ID = "http://schemas.microsoft.com/mapi/proptag/0x7FFE000B" - altered
    Dim olkPA As Outlook.PropertyAccessor, varTemp As Variant
    On Error Resume Next
    Set olkPA = olkAtt.PropertyAccessor
    varTemp = olkPA.GetProperty(PR_ATTACH_CONTENT_ID)
    IsHiddenAttachment = (Trim(varTemp) <> "")
    'Debug.Print varTemp
    On Error GoTo 0
    Set olkPA = Nothing
End Function

Select allOpen in new window