Save only attachments in attached body not attachments in email text

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:

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.

You can specify the valid extensions for oatt.FileName

Code:

---

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

Code:

---

    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/show...-to-hard-drive

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.

Attachment 15105

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

Code:

---

    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

---

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!

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!

This will get rid of the really small FB, Twitter etc logos:
http://www.slipstick.com/developer/s...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:
http://www.slipstick.com/developer/c...look-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...

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:

Code:

---

Sub FoldertoDocxMacroI()
'SOURCE: https://excel-macro.tutorialhorizon....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

---