Distinguish between visible and invisible attachments Outlook

A

aman

Registered User.
Local time
Yesterday, 16:31
Joined
Oct 16, 2008
Messages
1,251
Hi Guys

I have written following piece of code to save down attachments into pdf format on a shared drive but this code saves down logos/signatures in the email to the shared drive as well. I want to put a control that will ignore any invisible attachments and only the real attachments get save down .

Code: 
Private Sub SaveAttachments(olItem As Object)

Dim olAttach As Attachment
Dim strFName As String
Dim strExt As String
Dim j As Long
Dim olInsp As Inspector
Dim oRng As Object
Dim strTemp As String
Dim intPos As Integer
    strTemp = Environ("TEMP") & "\"
    
    If Not TypeName(olItem) = "MailItem" Then GoTo lbl_Exit
    
    CreateFolders strSaveFldr

    SaveAsPDFfile olItem

    If olItem.Attachments.Count > 0 Then
        For j = 1 To olItem.Attachments.Count
            Set olAttach = olItem.Attachments(j)
            Select Case LCase(Mid(olAttach.FileName, InStrRev(olAttach.FileName, Chr(46))))
                
                Case ".docx", ".doc", ".txt"
                    On Error Resume Next
                    olAttach.SaveAsFile strTemp & olAttach.FileName
                    Set wdApp = GetObject(, "Word.Application")
                    If Err Then
                        Set wdApp = CreateObject("Word.Application")
                    End If
                    On Error GoTo 0
                    wdApp.Visible = True
                    Set wdDoc = wdApp.Documents.Open(strTemp & olAttach.FileName)
                    intPos = InStrRev(olAttach.FileName, ".")
                    strFName = Left(olAttach.FileName, intPos - 1)
                    strFName = strFName & ".pdf"
                    strExt = Right(strFName, Len(strFName) - InStrRev(strFName, Chr(46)))
                    strFName = FileNameUnique(strSaveFldr, strFName, strExt)
                    wdDoc.ExportAsFixedFormat OutputFilename:=strSaveFldr & strFName, _
                                              ExportFormat:=17, _
                                              OpenAfterExport:=False, _
                                              OptimizeFor:=0, _
                                              Range:=0, _
                                              From:=0, _
                                              To:=0, _
                                              Item:=0, _
                                              IncludeDocProps:=True, _
                                              KeepIRM:=True, _
                                              CreateBookmarks:=0, _
                                              DocStructureTags:=True, _
                                              BitmapMissingFonts:=True, _
                                              UseISO19005_1:=True
                    wdDoc.Close 0
                    wdApp.Quit
                    
                    'If bWordWasNotRunning = True Then wdApp.Quit
                Case ".pdf", ".jpg", ".jpeg"
                    strFName = olAttach.FileName
                    strExt = Right(strFName, Len(strFName) - InStrRev(strFName, Chr(46)))
                    strFName = FileNameUnique(strSaveFldr, strFName, strExt)
                    olAttach.SaveAsFile strSaveFldr & strFName
                
                Case Else
                MsgBox olAttach.FileName
            End Select
            
            olItem.Categories = ""
            olItem.FlagStatus = olFlagComplete
            olItem.UnRead = False
            olItem.Save
        
        Next j
        
        olItem.Save
    
    End If
lbl_Exit:
    Set olAttach = Nothing
    Set olItem = Nothing
    Exit Sub
End Sub

ANy help will be much appreciated.
Thanks
 
The logos/signatures are jpg/jpeg format?

Is this procedure in Outlook?
 
Last edited:
Something you could try to remove logo/sig image files, is to convert the mail item to plai text. Maybe that would remove the file(s)
Code: 
 objYourMailItem.bodyFormat = olFormatPlain
Note I haven't tried it.

Something else to try is to parse the HTML in the message body and remove embedded images. This might remove the corresponding attachments.
 
How can I change my code accordingly? Thanks
 
I have some code that saves attachments and puts links to them in the email as we used to send a lot of large documents by email.

If you can be sure that every email will have signature logos, you might be able to differentiate by using the Type property.

From what I have seen in my emails if you have an email with attachment and signature logo, the attachment is of the type olEmbeddedItem and the signature as olByValue

However if no signature logo is present, then any real attachment then shows up as olByValue

HTH
 
I tried code testing for olEmbeddeditem type and nothing copies. Try with olByValue and get original output - everything.
 
OK, Sorry,

I went back to the message and found that the attachment was an email message. That is oviously classed differently, perhaps due to the way I placed it in the email, as I would have dragged the email message to the outgoing email.


June7 said:
I tried code testing for olEmbeddeditem type and nothing copies. Try with olByValue and get original output - everything.
Click to expand...
 

Attachments

  • olembed.PNG
    olembed.PNG
    17.9 KB · Views: 687
Already tried Type property. See post 7.

What do you mean by 'spares connection'?
 
Here is code to exclude embeded attachments. (logos, etc.) Only downloads "actual attachments" such as emails with the paper clip icon.

This is the code I use to download attachments from a specific email based on its subject and the date it was sent. It took me a lot of searching and rereading to figure out how to make it work.

The part of the code that is used to identify the attachment type is bold and non indented and came from vbaexpress in case you only need that part of the code to place in your existing function.


Code: 
Public Function ExtractOutlookAttachments(subj As String, dtsent As Date)
'https://stackoverflow.com/questions/15531093/save-attachments-to-a-folder-and-rename-them
'modified with code style "late binding" from ReadInbox
'20180807
'added PR_ATTACHMENT_HIDDEN to filter out embeded attachments
'http://www.vbaexpress.com/forum/showthread.php?58494-Outlook-Attachments
'20181025
'added AttachmentDate from email so that can have a reference point to
'locate the attachment in the downloads folder since the attachment may
'not be today's date.  Post #19, got to work by refering to MailObject
'rather than InboxAttachment
'https://chandoo.org/forum/threads/vba-code-to-export-outlook-emails-of-current-date-for-a-folder-to-excel.32771/
'20181029
'Changed to a function so can get back the attachment names
    Dim olAPP As Object                 'Late
    Dim Inbox As Object
    Dim InboxItems As Object
    Dim InboxAttachment As Object
    Dim Mailobject As Object
    Dim SaveFolder As String
    Dim SubjectFilter As String
    Dim stInboxAttachment As String
    Dim stExtractName As String
[B]Const PR_ATTACHMENT_HIDDEN = "http://schemas.microsoft.com/mapi/proptag/0x7FFE000B"
Dim olkPA As Object 'propertyAccessor[/B]

    'Set OlApp = CreateObject("Outlook.Application")    'Outlook Not Running
    On Error Resume Next
    Set olAPP = GetObject(, "Outlook.Application")      'Outlook Running
    If Err.Number <> 0 Then
        Err.Clear
        Set olAPP = CreateObject("Outlook.Application")
    End If
    '
    'Doc Control Inbox
    Set Inbox = olAPP.GetNamespace("Mapi").Folders("Doc Control").Folders("Inbox") 
    
    Set InboxItems = Inbox.Items
    Set InboxAttachment = Mailobject.Attachment
    SaveFolder = Environ("USERPROFILE") & "\Downloads\"  'C:\Temp\" ' THIS IS WHERE YOU WANT TO SAVE THE ATTACHMENT TO

    If Right(SaveFolder, 1) <> "\" Then SaveFolder = SaveFolder & "\"

    SubjectFilter = (subj)  '("Fwd: This is how to get attachments by subject") ' THIS IS WHERE YOU PLACE THE EMAIL SUBJECT FOR THE CODE TO FIND

    If Not Inbox Is Nothing Then
        For Each Mailobject In InboxItems
            If InStr(1, Mailobject.Subject, SubjectFilter) > 0 And InStr(1, Mailobject.SentOn, dtsent) > 0 Then
                For Each InboxAttachment In Mailobject.Attachments
[B]Set olkPA = InboxAttachment.propertyAccessor[/B]
[B]If olkPA.GetProperty(PR_ATTACHMENT_HIDDEN) = False Then[/B]
                    InboxAttachment.SaveAsFile SaveFolder & InboxAttachment.Filename
                    stInboxAttachment = stInboxAttachment & vbCrLf & InboxAttachment.Filename & " " & Mailobject.ReceivedTime
                    stExtractName = stExtractName & "," & SaveFolder & InboxAttachment.Filename
End If
                    Set InboxAttachment = Nothing
                Next
            End If
        Next
    End If
    
Finished:
    If Len(stInboxAttachment) > 0 Then
        MsgBox "The following are saved to the Downloads folder:" & vbCrLf & stInboxAttachment & vbCrLf & vbCrLf & _
                "Files carry original date which may not be today's date, so won't necessarily be at the top " & _
                "when sorting by date", vbOKOnly + vbInformation, "Saved Attachments"
        ExtractOutlookAttachments = stExtractName
    Else
        MsgBox "There were no attachments found.", vbOKOnly + vbInformation, "Saved Attachments"
    End If
    Set olAPP = Nothing
    Set Inbox = Nothing
    Set InboxItems = Nothing
    Set Mailobject = Nothing
End Function
 
Thanks so how can i change my code so that it excludes embedded attachments.
Code: 
Sub ProcessSelection()
Dim olMailItem As Object
      If Application.ActiveExplorer.Selection.Count = 0 Then
        MsgBox "No Items selected!", vbCritical, "Error"
        Exit Sub
    End If
    On Error Resume Next
    For Each olMailItem In Application.ActiveExplorer.Selection
             SaveAttachments olMailItem
           DoEvents
    Next olMailItem
Err_Handler:
    Set olMailItem = Nothing
lbl_Exit:
    Exit Sub
End Sub
Private Sub SaveAttachments(olItem As Object)

Dim olAttach As Attachment
Dim strFName As String
Dim strExt As String
Dim myNameSpace As Outlook.NameSpace
Dim myInbox As Outlook.Folder
Dim myDestFolder As Outlook.Folder
Dim myItems As Outlook.Items
Dim j As Long
Dim olInsp As Inspector
Dim oRng As Object
Dim strTemp As String
Dim intPos As Integer
    strTemp = Environ("TEMP") & "\"

Set myNameSpace = Application.GetNamespace("MAPI")
Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox)
Set myItems = myInbox.Items
Set myDestFolder = myInbox.Folders("Completed")
    
    If Not TypeName(olItem) = "MailItem" Then GoTo lbl_Exit
    
    CreateFolders strSaveFldr

    SaveAsPDFfile olItem

    If olItem.Attachments.Count > 0 Then
        For j = 1 To olItem.Attachments.Count
            Set olAttach = olItem.Attachments(j)
            Select Case LCase(Mid(olAttach.FileName, InStrRev(olAttach.FileName, Chr(46))))
                
                Case ".docx", ".doc", ".txt"
                    On Error Resume Next
                    olAttach.SaveAsFile strTemp & olAttach.FileName
                    Set wdApp = GetObject(, "Word.Application")
                    If Err Then
                        Set wdApp = CreateObject("Word.Application")
                    End If
                    On Error GoTo 0
                    wdApp.Visible = True
                    Set wdDoc = wdApp.Documents.Open(strTemp & olAttach.FileName)
                    intPos = InStrRev(olAttach.FileName, ".")
                    strFName = Left(olAttach.FileName, intPos - 1)
                    strFName = strFName & ".pdf"
                    strExt = Right(strFName, Len(strFName) - InStrRev(strFName, Chr(46)))
                    strFName = FileNameUnique(strSaveFldr, strFName, strExt)
                    wdDoc.ExportAsFixedFormat OutputFilename:=strSaveFldr & strFName, _
                                              ExportFormat:=17, _
                                              OpenAfterExport:=False, _
                                              OptimizeFor:=0, _
                                              Range:=0, _
                                              From:=0, _
                                              To:=0, _
                                              Item:=0, _
                                              IncludeDocProps:=True, _
                                              KeepIRM:=True, _
                                              CreateBookmarks:=0, _
                                              DocStructureTags:=True, _
                                              BitmapMissingFonts:=True, _
                                              UseISO19005_1:=True
                    wdDoc.Close 0
                    wdApp.Quit
                    
                    'If bWordWasNotRunning = True Then wdApp.Quit
                Case ".pdf", ".jpg", ".jpeg"
                    strFName = olAttach.FileName
                    strExt = Right(strFName, Len(strFName) - InStrRev(strFName, Chr(46)))
                    strFName = FileNameUnique(strSaveFldr, strFName, strExt)
                    olAttach.SaveAsFile strSaveFldr & strFName
                
                Case Else
            
            End Select
           
            olItem.Categories = ""
            olItem.FlagStatus = olFlagComplete
            olItem.UnRead = False
            olItem.Save
            olItem.Move myDestFolder
            Set olItem = myItems.FindNext
        Next j
        
        olItem.Save
    
    End If
lbl_Exit:
    Set olAttach = Nothing
    Set olItem = Nothing
    Exit Sub
End Sub
 
sxschech,

I'm trying to implement that in my code, but the olkPA (oPA in mine) is always blank?

That url does not exist anymore?, would that be why?

This would be brilliant if I could get this to work.

TIA
Code: 
Public Sub ReplaceAttachmentsToLink()
    Dim objApp As Outlook.Application
    Dim aMail As Outlook.MailItem    'Object
    Dim oAttachments As Outlook.Attachments
    Dim oSelection As Outlook.Selection
    Dim oPA As Object
    Dim i As Long
    Dim iCount As Long
    Dim sFile As String
    Dim sFolderPath As String
    Dim sDeletedFiles As String
    Dim sDate As String, sTime As String

    Const PR_ATTACHMENT_HIDDEN = "http://schemas.microsoft.com/mapi/proptag/0x7FFE000B"
    
    ' Get the path to your My Documents folder
    sFolderPath = CreateObject("WScript.Shell").SpecialFolders(16)
    On Error Resume Next

    ' Instantiate an Outlook Application object.
    Set objApp = CreateObject("Outlook.Application")

    ' Get the collection of selected objects.
    Set oSelection = objApp.ActiveExplorer.Selection

    ' Set the Attachment folder.
    sFolderPath = sFolderPath & "\OLAttachments"

    'If folder does not exist create it
    If Dir(sFolderPath, vbDirectory) = "" Then
        MkDir sFolderPath
    End If

    ' Check each selected item for attachments. If attachments exist,
    ' save them to the Temp folder and strip them from the item.
    For Each aMail In oSelection

        ' This code only strips attachments from mail items.
        ' If aMail.class=olMail Then
        ' Get the Attachments collection of the item.
        Set oAttachments = aMail.Attachments
        iCount = oAttachments.Count

        If iCount > 0 Then
            ' We need to use a count down loop for removing items
            ' from a collection. Otherwise, the loop counter gets
            ' confused and only every other item is removed.
            For i = iCount To 1 Step -1
                Set oPA = oAttachments.PropertyAccessor
                If oPA.GetProperty(PR_ATTACHMENT_HIDDEN) = False Then
                    ' Save attachment before deleting from item.
                    ' Get the file name.
                    sFile = oAttachments.Item(i).FileName

                    'Now get Date & Time as strings to use in filename, but use received date & time
                    sDate = Format(aMail.ReceivedTime, "yyyymmdd")
                    sTime = Format(aMail.ReceivedTime, "hhmmss")

                    ' Combine with the path to the Temp folder.
                    sFile = sFolderPath & "\" & sDate & "_" & sTime & "_" & sFile

                    ' Save the attachment as a file.
                    oAttachments.Item(i).SaveAsFile sFile

                    ' Delete the attachment.
                    oAttachments.Item(i).Delete

                    'write the save as path to a string to add to the message
                    'check for html and use html tags in link
                    If aMail.BodyFormat <> olFormatHTML Then
                        sDeletedFiles = sDeletedFiles & vbCrLf & "<file://" & sFile & ">"
                    Else
                        sDeletedFiles = sDeletedFiles & "<br>" & "<a href='file://" & _
                                        sFile & "'>" & sFile & "</a>"
                    End If
                End If
            Next i

            ' Adds the filename string to the message body and save it
            ' Check for HTML body
            If aMail.BodyFormat <> olFormatHTML Then
                aMail.Body = aMail.Body & vbCrLf & _
                             "The file(s) were saved to " & sDeletedFiles
            Else
                aMail.HTMLBody = aMail.HTMLBody & "<p>" & _
                                 "The file(s) were saved to " & sDeletedFiles & "</p>"
            End If

            aMail.Save
            'sets the attachment path to nothing before it moves on to the next message.
            sDeletedFiles = ""

        End If
    Next    'end aMail

ExitSub:

    Set oAttachments = Nothing
    Set aMail = Nothing
    Set oSelection = Nothing
    Set objApp = Nothing
End Sub
 
Thanks a lot sxschech. It works like a charm to me. Many Many thanks for all your help :)

sxschech said:
Here is code to exclude embeded attachments. (logos, etc.) Only downloads "actual attachments" such as emails with the paper clip icon.

This is the code I use to download attachments from a specific email based on its subject and the date it was sent. It took me a lot of searching and rereading to figure out how to make it work.

The part of the code that is used to identify the attachment type is bold and non indented and came from vbaexpress in case you only need that part of the code to place in your existing function.


Code: 
Public Function ExtractOutlookAttachments(subj As String, dtsent As Date)
'https://stackoverflow.com/questions/15531093/save-attachments-to-a-folder-and-rename-them
'modified with code style "late binding" from ReadInbox
'20180807
'added PR_ATTACHMENT_HIDDEN to filter out embeded attachments
'http://www.vbaexpress.com/forum/showthread.php?58494-Outlook-Attachments
'20181025
'added AttachmentDate from email so that can have a reference point to
'locate the attachment in the downloads folder since the attachment may
'not be today's date.  Post #19, got to work by refering to MailObject
'rather than InboxAttachment
'https://chandoo.org/forum/threads/vba-code-to-export-outlook-emails-of-current-date-for-a-folder-to-excel.32771/
'20181029
'Changed to a function so can get back the attachment names
    Dim olAPP As Object                 'Late
    Dim Inbox As Object
    Dim InboxItems As Object
    Dim InboxAttachment As Object
    Dim Mailobject As Object
    Dim SaveFolder As String
    Dim SubjectFilter As String
    Dim stInboxAttachment As String
    Dim stExtractName As String
[B]Const PR_ATTACHMENT_HIDDEN = "http://schemas.microsoft.com/mapi/proptag/0x7FFE000B"
Dim olkPA As Object 'propertyAccessor[/B]

    'Set OlApp = CreateObject("Outlook.Application")    'Outlook Not Running
    On Error Resume Next
    Set olAPP = GetObject(, "Outlook.Application")      'Outlook Running
    If Err.Number <> 0 Then
        Err.Clear
        Set olAPP = CreateObject("Outlook.Application")
    End If
    '
    'Doc Control Inbox
    Set Inbox = olAPP.GetNamespace("Mapi").Folders("Doc Control").Folders("Inbox") 
    
    Set InboxItems = Inbox.Items
    Set InboxAttachment = Mailobject.Attachment
    SaveFolder = Environ("USERPROFILE") & "\Downloads\"  'C:\Temp\" ' THIS IS WHERE YOU WANT TO SAVE THE ATTACHMENT TO

    If Right(SaveFolder, 1) <> "\" Then SaveFolder = SaveFolder & "\"

    SubjectFilter = (subj)  '("Fwd: This is how to get attachments by subject") ' THIS IS WHERE YOU PLACE THE EMAIL SUBJECT FOR THE CODE TO FIND

    If Not Inbox Is Nothing Then
        For Each Mailobject In InboxItems
            If InStr(1, Mailobject.Subject, SubjectFilter) > 0 And InStr(1, Mailobject.SentOn, dtsent) > 0 Then
                For Each InboxAttachment In Mailobject.Attachments
[B]Set olkPA = InboxAttachment.propertyAccessor[/B]
[B]If olkPA.GetProperty(PR_ATTACHMENT_HIDDEN) = False Then[/B]
                    InboxAttachment.SaveAsFile SaveFolder & InboxAttachment.Filename
                    stInboxAttachment = stInboxAttachment & vbCrLf & InboxAttachment.Filename & " " & Mailobject.ReceivedTime
                    stExtractName = stExtractName & "," & SaveFolder & InboxAttachment.Filename
End If
                    Set InboxAttachment = Nothing
                Next
            End If
        Next
    End If
    
Finished:
    If Len(stInboxAttachment) > 0 Then
        MsgBox "The following are saved to the Downloads folder:" & vbCrLf & stInboxAttachment & vbCrLf & vbCrLf & _
                "Files carry original date which may not be today's date, so won't necessarily be at the top " & _
                "when sorting by date", vbOKOnly + vbInformation, "Saved Attachments"
        ExtractOutlookAttachments = stExtractName
    Else
        MsgBox "There were no attachments found.", vbOKOnly + vbInformation, "Saved Attachments"
    End If
    Set olAPP = Nothing
    Set Inbox = Nothing
    Set InboxItems = Nothing
    Set Mailobject = Nothing
End Function
Click to expand...
 
That is brilliant! Got it to work.

@Gasman, try:

Set olPA = objAttachments.Item(i).PropertyAccessor
 
June7,

Sadly that did not work.

Code: 
            For i = iCount To 1 Step -1
                Set oPA = oAttachments.Item(i).PropertyAccessor
                If oPA.GetProperty(PR_ATTACHMENT_HIDDEN) = False Then
                    ' Save attachment before deleting from item.

oPA does now get set and I can see PropertyAssessor as the class, See pic

Oh, so close :banghead:

Perhaps does not work in 2007 ?

June7 said:
That is brilliant! Got it to work.

@Gasman, try:

Set olPA = objAttachments.Item(i).PropertyAccessor
Click to expand...
 

Attachments

  • oPA.PNG
    oPA.PNG
    4.9 KB · Views: 654
Last edited:
Don't know what else to say. Our code is essentially the same.
 
June7 said:
Don't know what else to say. Our code is essentially the same.
Click to expand...

That is why I think it might be down to 2007. I've had issues like this in the past with isladogs. Nothing seems different, yet it does not work for me or throws and error.

Even tried
Code: 
    Const PR_ATTACHMENT_HIDDEN As String = "http://schemas.microsoft.com/mapi/proptag/0x7FFE000B"
which I found at https://stackoverflow.com/questions/12310925/distinguish-visible-and-invisible-attachments-with-outlook-vba
Ah well. :(
 
Last edited:
aman: glad you got the code to work for you.
Gasman: sorry the code isn't working for you. I am running Access 2013 and don't have 2007, so can't test it out.
 
Not to worry.

I'll try and follow it up now I know the property name.

Good post though, thank you.

sxschech said:
aman: glad you got the code to work for you.
Gasman: sorry the code isn't working for you. I am running Access 2013 and don't have 2007, so can't test it out.
Click to expand...
 
I think it must be something to do with 2007, or my setup if it definitely works in 2007.?
I have downloaded MFCMAPI and following some instructions on the net, I should be able to see that property, however when I go to open the attachments table in MFCMAPI, nothing happens.:(
 
You must log in or register to reply here.

Similar threads

K
How can I add this code to the storage location of my file before scanning and then convert it to a PDF file?
2
Replies
25
Views
2,414
The_Doc_Man
The_Doc_Man
M
Multiple attachments and a report in the same email
Replies
15
Views
2,142
Marshall Brooks
M
G
Invalid procedure call or argument brows and attach file
2
Replies
23
Views
3,123
Minty
Minty
R
Access DB attachments form and VBA
Replies
15
Views
3,377
rdab100
R
M
Solved Run Time Error while attaching the PDF to the Email
Replies
13
Views
2,252
mrk777
M

Users who are viewing this thread

Total: 1 (members: 0, guests: 1)
Back
Top Bottom