VBA Bulk save attachments from multiple emails code downloads everything including pictures

Question

I was using a code that download attachments from multiple emails in my Outlook at once. I applied the same code in my new job's outlook and it works but it also downloads all the items included in the body of the emails such as pictures and I only wish to download files included as attachments, which are usually .pdfs files. Maybe just restrict the code to download PDFs would work for me. Thanks

    Public Sub SaveA()
'Update 20200821
Dim xMailItem As Outlook.MailItem
Dim xAttachments As Outlook.Attachments
Dim xSelection As Outlook.Selection
Dim i As Long
Dim xAttCount As Long
Dim xFilePath As String, xFolderPath As String, xSaveFiles As String
Dim xYesNo As Integer
Dim xFlag As Boolean
On Error Resume Next
xFolderPath = CreateObject("WScript.Shell").SpecialFolders(16)
Set xSelection = Outlook.Application.ActiveExplorer.Selection
xFolderPath = xFolderPath & "\Attachments\"
If VBA.Dir(xFolderPath, vbDirectory) = vbNullString Then
    VBA.MkDir xFolderPath
End If
For Each xMailItem In xSelection
    Set xAttachments = xMailItem.Attachments
    xAttCount = xAttachments.Count
    xSaveFiles = ""
    If xAttCount > 0 Then
        For i = xAttCount To 1 Step -1
            xFilePath = xFolderPath & xAttachments.Item(i).FileName
            xFlag = True
            If VBA.Dir(xFilePath, 16) <> Empty Then
                xYesNo = MsgBox("The file is exists, do you want to replace it", vbYesNo + vbInformation, "Kutools for Outlook")
                If xYesNo = vbNo Then xFlag = False
            End If
            If xFlag = True Then
                xAttachments.Item(i).SaveAsFile xFilePath
                If xMailItem.BodyFormat <> olFormatHTML Then
                    xSaveFiles = xSaveFiles & vbCrLf & "<Error! Hyperlink reference not valid.>"
                Else
                    xSaveFiles = xSaveFiles & "<br>" & "<a href='file://" & xFilePath & "'>" & xFilePath & "</a>"
                End If
            End If
        Next i
        If xSaveFiles <> "" Then
            If xMailItem.BodyFormat <> olFormatHTML Then
                xMailItem.Body = vbCrLf & "The file(s) were saved to " & xSaveFiles & vbCrLf & xMailItem.Body
            Else
                xMailItem.HTMLBody = "<p>" & "The file(s) were saved to " & xSaveFiles & "</p>" & xMailItem.HTMLBody
            End If
        End If
        xMailItem.Save
    End If
Next
Set xAttachments = Nothing
Set xMailItem = Nothing
Set xSelection = Nothing
End Sub

Answer 1

You need to check the HTMLBody property and see if any attachments are actually referenced by the <img> tags. The value used for the <img> tags can be set in the MIME content id (PR_ATTACH_CONTENT_ID). So, first you retrieve the content ID and then search for the value in the message body. For example:

Function CountVisibleAttachment(ByVal m As MailItem) As Integer
    Const PR_ATTACH_CONTENT_ID As String = "http://schemas.microsoft.com/mapi/proptag/0x3712001F"
    Const PR_ATTACHMENT_HIDDEN As String = "http://schemas.microsoft.com/mapi/proptag/0x7FFE000B"

    Dim a As Attachment
    Dim pa As propertyAccessor
    Dim c As Integer
    Dim cid As String

    Dim body As String

    c = 0

    body = m.HTMLBody

    For Each a In m.Attachments
        Set pa = a.propertyAccessor
        cid = pa.GetProperty(PR_ATTACH_CONTENT_ID)

        If Len(cid) > 0 Then
            If InStr(body, cid) Then
            emb = emb + 1
            Else
                'In case that PR_ATTACHMENT_HIDDEN does not exists,
                'an error will occur. We simply ignore this error and
                'treat it as false.
                On Error Resume Next
                If Not pa.GetProperty(PR_ATTACHMENT_HIDDEN) Then
                    c = c + 1
                End If
                On Error GoTo 0
            End If
        Else
            c = c + 1
        End If
    Next a
    CountVisibleAttachment = c
End Function