Distinguish between visible and invisible attachments Outlook (1 Viewer)

aman

Registered User.
Local time
Today, 08:38
Joined
Oct 16, 2008
Messages
1,250
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
 

June7

AWF VIP
Local time
Today, 07:38
Joined
Mar 9, 2014
Messages
5,423
The logos/signatures are jpg/jpeg format?

Is this procedure in Outlook?
 
Last edited:

Cronk

Registered User.
Local time
Tomorrow, 02:38
Joined
Jul 4, 2013
Messages
2,770
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.
 

aman

Registered User.
Local time
Today, 08:38
Joined
Oct 16, 2008
Messages
1,250
How can I change my code accordingly? Thanks
 

Gasman

Enthusiastic Amateur
Local time
Today, 15:38
Joined
Sep 21, 2011
Messages
14,044
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
 

June7

AWF VIP
Local time
Today, 07:38
Joined
Mar 9, 2014
Messages
5,423
I tried code testing for olEmbeddeditem type and nothing copies. Try with olByValue and get original output - everything.
 

Gasman

Enthusiastic Amateur
Local time
Today, 15:38
Joined
Sep 21, 2011
Messages
14,044
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.


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

Attachments

  • olembed.PNG
    olembed.PNG
    17.9 KB · Views: 544

June7

AWF VIP
Local time
Today, 07:38
Joined
Mar 9, 2014
Messages
5,423
Already tried Type property. See post 7.

What do you mean by 'spares connection'?
 

sxschech

Registered User.
Local time
Today, 08:38
Joined
Mar 2, 2010
Messages
791
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
 

aman

Registered User.
Local time
Today, 08:38
Joined
Oct 16, 2008
Messages
1,250
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
 

Gasman

Enthusiastic Amateur
Local time
Today, 15:38
Joined
Sep 21, 2011
Messages
14,044
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
 

aman

Registered User.
Local time
Today, 08:38
Joined
Oct 16, 2008
Messages
1,250
Thanks a lot sxschech. It works like a charm to me. Many Many thanks for all your help :)

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
 

June7

AWF VIP
Local time
Today, 07:38
Joined
Mar 9, 2014
Messages
5,423
That is brilliant! Got it to work.

@Gasman, try:

Set olPA = objAttachments.Item(i).PropertyAccessor
 

Gasman

Enthusiastic Amateur
Local time
Today, 15:38
Joined
Sep 21, 2011
Messages
14,044
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 ?

That is brilliant! Got it to work.

@Gasman, try:

Set olPA = objAttachments.Item(i).PropertyAccessor
 

Attachments

  • oPA.PNG
    oPA.PNG
    4.9 KB · Views: 540
Last edited:

June7

AWF VIP
Local time
Today, 07:38
Joined
Mar 9, 2014
Messages
5,423
Don't know what else to say. Our code is essentially the same.
 

Gasman

Enthusiastic Amateur
Local time
Today, 15:38
Joined
Sep 21, 2011
Messages
14,044
Don't know what else to say. Our code is essentially the same.

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:

sxschech

Registered User.
Local time
Today, 08:38
Joined
Mar 2, 2010
Messages
791
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.
 

Gasman

Enthusiastic Amateur
Local time
Today, 15:38
Joined
Sep 21, 2011
Messages
14,044
Not to worry.

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

Good post though, thank you.

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.
 

Gasman

Enthusiastic Amateur
Local time
Today, 15:38
Joined
Sep 21, 2011
Messages
14,044
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.:(
 

Users who are viewing this thread

Top Bottom