Save only attachment from email in outlook

I've problem with automatically saved attachment in Outlook,

So basically the code is to saved selected attachment in emails to specific folder, however it's not only saved the attachment inside the email, but also saved other type of images in the email as well(not in the attachment).

I couldn't find any solution to make the code only choose the item in the attachment to save.

Here is the full code :

Dim Attachments As Outlook.Attachments
Dim AttachmentsCount As Integer
Dim Email As Outlook.MailItem
Dim FolderObj As Object
Dim FolderPath As String
Dim i As Long
Dim OutlookApp As Outlook.Application
Dim Selection As Outlook.Selection
Dim User As String
     
FolderPath = "C:\XXX\Desktop\TestAttachment"
  
Set FolderObj = CreateObject("Scripting.FileSystemObject")
If FolderObj.FolderExists(FolderPath) Then 
Else: FolderObj.CreateFolder (FolderPath)
End If
   
Set OutlookApp = Outlook.Application
Set Selection = OutlookApp.ActiveExplorer.Selection 
  
AttachmentsCount = 0
  
For Each Email In Selection

Set Attachments = Email.Attachments
For i = Attachments.Count To 1 Step -1

Attachments.Item(i).SaveAsFile FolderPath & "\" & Format(Email.ReceivedTime, "DD.MM.YYYY hhmm") & "_" & Attachments.Item(i).fileName
AttachmentsCount = AttachmentsCount + 1

Next i

Next
  
If AttachmentsCount > 0 Then
MsgBox "Email Attachment(s) have been saved."
ElseIf AttachmentsCount = 0 Then
MsgBox "No Attachment were found to save."
End If

Solution

in HTML format all pictures are regarded as attachments and showed in body of the e-mail. I've tried your code, it's working, but Attachments.Count is more then shown as attachments. In my case- 1 .xlsx file is displayed as attachments and 4 small images in body.

You can check if the attachment is embedded with function

Sub saveatt()
Dim Attachments As Outlook.Attachments
Dim AttachmentsCount As Integer
Dim Email As Outlook.MailItem
Dim FolderObj As Object
Dim FolderPath As String
Dim i As Long
Dim OutlookApp As Outlook.Application
Dim Selection As Outlook.Selection
Dim User As String
     
FolderPath = "C:\Users\xxx\Downloads"
  
Set FolderObj = CreateObject("Scripting.FileSystemObject")
If FolderObj.FolderExists(FolderPath) Then
Else: FolderObj.CreateFolder (FolderPath)
End If
   
Set OutlookApp = Outlook.Application
Set Selection = OutlookApp.ActiveExplorer.Selection
  
AttachmentsCount = 0
  
For Each Email In Selection

Set Attachments = Email.Attachments
For i = Attachments.Count To 1 Step -1
 If IsEmbeddedAttachment(Attachments.Item(i)) = False Then
Attachments.Item(i).SaveAsFile FolderPath & "\" & Format(Email.ReceivedTime, "DD.MM.YYYY hhmm") & "_" & Attachments.Item(i).FileName
AttachmentsCount = AttachmentsCount + 1
End If
Next i

Next
  
If AttachmentsCount > 0 Then
MsgBox "Email Attachment(s) have been saved."
ElseIf AttachmentsCount = 0 Then
MsgBox "No Attachment were found to save."
End If

End Sub

Function IsEmbeddedAttachment(Attach As Attachment)
Dim xItem As MailItem
Dim xCid As String
Dim xID As String
Dim xHtml As String
On Error Resume Next
IsEmbeddedAttachment = False
Set xItem = Attach.Parent
If xItem.BodyFormat <> olFormatHTML Then Exit Function
xCid = ""
xCid = Attach.PropertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x3712001F")
If xCid <> "" Then
    xHtml = xItem.HTMLBody
    xID = "cid:" & xCid
    If InStr(xHtml, xID) > 0 Then
        IsEmbeddedAttachment = True
    End If
End If
End Function

This way works