Save only attachments in attached body not attachments in email text

[Borino]

Hi all,

I keep on trying to archive my emails from outlook via vba. I have managed to download the emails with certain names and save the attachments. What I have not been able to do is this: I want to save the attachments which are really attached by the sender in the attached area. What I don't want to do is save all the pictures/frames which usually come in signatures and logo's. The code that I have now keeps seeing these pictures and logos and attachments which results in a pile of image.png and a lot of LinkedIn and Twitter logo's.

Here is a section of my code:


If Item.Attachments.Count = 0 Then
' Email bevat geen bijlagen. Email wordt opgeslagen in Email directory
If Dir(StrMail, vbDirectory) = "" Then
Item.SaveAs StrMail
Else
GoTo 104
End If
ElseIf Item.Attachment.Count >= 1 Then
' Email bevat bijlagen. Bijlagen worden opgeslagen in Bijlagen directory
' Email wordt opgeslagen in Email directory
If Dir(StrMail, vbDirectory) = "" Then
Item.SaveAs StrMail
Else
GoTo 104
End If
For Each oatt In Item.Attachments
If Dir(DirAtt & oatt.FileName, vbDirectory) = "" Then
oatt.SaveAsFile DirAtt & oatt.FileName
End If
Next
End If

Can somebody help me how to figure out that only the attachments which are attached by the sender will be downloaded?

Thanks in advance.

[skatonni]

You can specify the valid extensions for oatt.FileName


For Each oatt In Item.Attachments

' Code here to determine extension of oatt.FileName
' If you wanted xls files
If ext = "xls" then Then
If Dir(DirAtt & oatt.FileName, vbDirectory) = "" Then
oatt.SaveAsFile DirAtt & oatt.FileName
End If
End If
Next

Or

You can exclude certain attachments



For Each oatt In Item.Attachments
If Not oatt.FileName Like "image*.*" Then
If Dir(DirAtt & oatt.FileName, vbDirectory) = "" Then
oatt.SaveAsFile DirAtt & oatt.FileName
End If
End If
Next

More if you need it here. http://www.vbaexpress.com/forum/showthread.php?51429-Save-attachments-in-specified-folder-to-hard-drive

[Borino]

That's an option to work with but then you have to make a list of all the extension that you do want to save and the ones you don't. And in some cases for work I do get an picture or an image which is attached by the sender, which I want to save in that case.

What I don't want is to save attachments which are in the text of the email (usually the images and png in email signatures).

See the picture for an example. So I only want to save the Excel file in this case and not the Company Logo, LinkedIn logo and Twitter Logo.

15105

[gmayor]

It is probably simpler to omit the files you don't want. The following should cover most of them and you could include any others that you want to lose


For Each oatt In item.Attachments
If Not oatt.FileName Like "image*.*" Then
If Dir(DirAtt & oatt.FileName, vbDirectory) = "" Then
oatt.SaveAsFile DirAtt & oatt.FileName
End If
End If
Next oatt

[Borino]

OK. This works for all the files which are named image. How do I add more file names like picture*.* With an or function added to it?

I still find it strange that I can't count and select the files which are actually in the attached body.

Still hoping for another answer from somebody who does know the trick.

Thanks in advance gmayor!

[Borino]

Hi all,

Anybody else with a possible answer how to get the attachments out of the attached body? Instead of all the attachment such as email signatures and logo's.

Hope to find some sort of an answer here.

Thanks in advance!

[james_martin]

This will get rid of the really small FB, Twitter etc logos:
www.slipstick.com/developer/save-attachments-to-the-hard-drive
You have to add an extra if objattachments.item(i).Size > 5200 Then

5200 bytes is suggested and small logos are not saved as Attachments.

The problem I have is that signature banners are so wide now for companies,
but generally not over 180 pixels in height.

Will try some of the VBA on this page, or I will have to try to isolate via
the htmlbody tags.

Personally put a folder kill command before this attachment macro works,
So don't confuse clients.

I have an image macro to import the IMG attachments to the docx save of the email
Also via slipstick at:
www.slipstick.com/developer/code-samples/save-outlook-email-pdf
I followed the instructions to save as docx with Header, this includes client's
Embedded photos and the email signatures.

Confusingly the attachment macro duplicates the signatures only.

I have only partially resolved as some signature banners are larger in size
than a blank docx...

[james_martin]

Solved the prevention of signature images and banners via
stage two Macro "I" being imported into the client active document.
Basically the function to add picture, before it loops round to the next attachment,
I've finally managed to get the code to delete out the IMG attachment
if the height is less than 180:


Sub FoldertoDocxMacroI()
'SOURCE: https://excel-macro.tutorialhorizon.com/vba-excel-addinsert-multiple-imagespictures-from-a-folder-in-word-document/
Application.screenupdating = False
FnInsertMultipleImages ("C:\traajsmn\attach")
'Error Handler needed to not select *.heic files I have had to abandon ...\attachments\ today as cant delete heic files 19/10/2021
''Set oDoc = Nothing
Application.screenupdating = True
End Sub

Function FnInsertMultipleImages(strFolderPath)
Dim objWord
Dim objDoc
Dim objSelection
Dim objShapes
Dim objShape '''
Dim oShape As InlineShape '''
Dim Shape As Shape
Dim objFSO
Dim objFolder
Set objWord = GetObject(, "Word.Application") '01/11/2021 Changed Create for Get & inserted a comma in the brackets
'CREDIT: microsoft.public.word.vba.general.narkive.com/wqS1d0hC/stop-multiple-instances-of-word-opening
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(strFolderPath)
Set objDoc = Word.ActiveDocument
Set objSelection = Word.ActiveDocument
For Each img In objFolder.files
imgpath = img.Path
'''saw 09112021 macro delete the original signature banner aswell so did not work, maybe this will:
'''stackoverflow.com/questions/20553813/adjust-image-properties-with-addpicture-method-word-vba
Set oShape = objSelection.Inlineshapes.AddPicture(imgpath)
If oShape.Height < 180 Then
oShape.Delete
End If
Next
End Function