asked on

Remove Outlook Attachments, But Not Inline Images

In order to reduce PST size, I've written a routine that removes attachments from a given e-mail. asks me to save them, and inserts a list of removed attachments below the body text. This is available through a button in an open e-mail and is triggered whenever I've sent an e-mail.

It works perfectly, except for the fact that it *also* removes images embedded in the e-mail body (HTML format). It seems that I cannot distinguish through code between attachments and attachments posing as inline images. The FileName and DisplayName properties are no help, nor is the Position property, which gives me the position of the attachments relative to the Body, not the HTMLBody (or I could simply look for an IMG tag at the Position). The IMG tags in the HTMLBody refer to a CID code, not to the file name, so I can't use that either to determine which attachments are actually inline pictures.

I've considered the following extremely fault sensistive and cumbersome solution:
- Check each attachment's Position
- Look in the Body before the Position and register what text, if any, is there
- Look for that text in the HTMLBody and check if the text is followed (closely) by an IMG tag.

This might work, kinda, but seems rather complicated for something that should be simple.

Ideas?

Chris Bottomley

Hello FlorisMK,

I believe that for example via redemption the nature of the attachments as embeded etc can be identified ... however in a similar position i.e. seeking to redcuce PST sizes I looked at the attachment size and if over x then I saved it to the HD and included it as a link in the email as well.

Regards,

chris_bottomley

Khalid Mehmood Awan

I guess, images within email body are treated as attachment when they are saved to PST.

David Lee

Hi, FlorisMK.

What version of Outlook are you using?

FlorisMK

ASKER

Thanks, chris - looking at size doesn't solve the embedded image issue though, except for the advantage that the picture can be easily retrieved through the link you create. Using Redemption is not an option in our TS environment.

khalid, yes, that is true and lies at the root of the problem.

BlueDevilFan: I'm in Outlook 2003, but have the same problem in 2007 and had the same problem in 2000, I think.

Khalid Mehmood Awan

to add more, inline images when saved as attachment usually have Image001.jpg like format ;-)

That can help you do the trick, you can skip deleting any such attachment...

Chris Bottomley

AGreed

I have been working on this in the meantime ... as yet I am getting a failure with 1 email though thousands work ok so see how it goes for you. Basically it excludes OLE files.

Chris

Sub ini_attachStrip()
Dim mai As mailitem
Dim saveAttFolder As String
Dim fldr As Object
Dim myPSTs As Object
    
    saveAttFolder = Environ("userprofile") & "\my documents\mailattachments"
    md saveAttFolder, True
    For Each myPSTs In Application.Session.Folders
        If myPSTs.Name <> "Public Folders" Then
            For Each fldr In myPSTs.Folders
                attachStrip fldr, saveAttFolder
            Next
        End If
    Next
 
End Sub
 
Function md(dosPath As String, Optional createFolders As Boolean)
Dim FSO As Object
Dim fldrs() As String
Dim rootdir As String
Dim fldrIndex As Integer
    
    md = True
    Set FSO = CreateObject("Scripting.FileSystemObject")
    If Not FSO.FolderExists(dosPath) Then
        fldrs = Split(dosPath, "\")
        rootdir = fldrs(0)
        If Not FSO.FolderExists(rootdir) Then
            md = False
            Exit Function
        End If
 
        For fldrIndex = 1 To UBound(fldrs)
            rootdir = rootdir & "\" & fldrs(fldrIndex)
            If Not FSO.FolderExists(rootdir) Then
                If createFolders Then
                    FSO.CreateFolder rootdir
                Else
                    md = False
                End If
            End If
        Next
        Exit Function
    End If
End Function
Sub attachStrip(fldr As Object, saveFolder As String)
Dim att As Attachment
Dim DOSFile As String
Dim intAttCount As Integer
Dim lngMailCount As Long
Dim saveAttAs(1 To 3) As String
Dim verNumber As Integer
Dim obj As Object
Dim mai As mailitem
Dim subFolder As Object
Dim FSO As Object
Const sizelimit As Long = 5196
' Secure email Issue see : http://support.microsoft.com/kb/896594
 
    If FSO Is Nothing Then Set FSO = CreateObject("scripting.filesystemobject")
    If fldr.DefaultItemType <> olMailItem Then Exit Sub
    For lngMailCount = fldr.items.Count To 1 Step -1
        Set obj = fldr.items(lngMailCount)
        If obj.Class = olMail Then
            Err.Clear
            On Error Resume Next
            Set mai = obj
            On Error GoTo 0
            If Err.Number = 13 Then GoTo assumeEncrypted
            If mai Is Nothing Then GoTo maiIsNothing
            Err.Clear
            For intAttCount = mai.Attachments.Count To 1 Step -1
                Set att = mai.Attachments(intAttCount)
                If att.Type <> olOLE Then
                    verNumber = 1
                    saveAttAs(1) = saveFolder
                    If Right(saveAttAs(1), 1) <> "\" Then saveAttAs(1) = saveAttAs(1) & "\"
                    saveAttAs(1) = saveAttAs(1) & Left(mai.Attachments.item(intAttCount).filename, InStrRev("." & mai.Attachments.item(intAttCount).filename, ".") - 1)
                    saveAttAs(2) = "_ver-" & verNumber
                    saveAttAs(3) = Right(mai.Attachments.item(intAttCount).filename, Len(mai.Attachments.item(intAttCount).filename) - InStrRev(mai.Attachments.item(intAttCount).filename, ".") + 1)
                    DOSFile = Dir(Join(saveAttAs, ""))
                    Do While DOSFile <> ""
                        'That file name found so increment affix
                        verNumber = verNumber + 1
                        saveAttAs(2) = "_ver-" & verNumber
                        DOSFile = Dir(Join(saveAttAs, ""))
                    Loop
                    att.SaveAsFile Join(saveAttAs, "")
'                    Debug.Print Join(saveAttAs, "") & "  ||  " & FSO.GetFile(Join(saveAttAs, "")).Size
'                    att.Delete
'                    mai.Body = mai.Body & vbCrLf & "<file://" & Join(saveAttAs, "") & ">"
'                    mai.Save
                End If
assumeEncrypted:
assumeEmbedded:
            Next
        End If
'        If mai.EntryID = "000000003023B0509815D2119E8D0008C742B26804939900" Then Stop
maiIsNothing:
    Next
    For Each subFolder In fldr.Folders
        attachStrip subFolder, saveFolder
    Next
 
End Sub
Sub testing1(Optional str As String)
 
End Sub
 
Private Sub testing2()
    testing1
End Sub
 
Sub saveAttachments(Optional mai As Object)
Dim att As Attachment
Dim DOSFile As String
Dim saveAttAs(1 To 3) As String
Dim verNumber As Integer
'Dim mai As Object
Dim intAttCount As Integer
Const saveFolder As String = "C:\Documents and Settings\cbottom1\My Documents\MailAttachments"
 
    If Not mai Is Nothing Then
    ElseIf TypeName(Application.ActiveWindow) = "Explorer" Then
        Set mai = Application.ActiveExplorer.Selection.item(1)
    ElseIf TypeName(Application.ActiveWindow) = "Inspector" Then
        Set mai = Application.ActiveInspector.CurrentItem
    Else
        Exit Sub
    End If
    If mai.Class <> olMail Then Exit Sub
    For intAttCount = mai.Attachments.Count To 1 Step -1
        Set att = mai.Attachments(intAttCount)
        If att.Type <> olOLE And att.Type <> olEmbeddeditem Then
            If InStr(att.filename, ".") > 0 Then
                verNumber = 1
                saveAttAs(1) = saveFolder
                If Right(saveAttAs(1), 1) <> "\" Then saveAttAs(1) = saveAttAs(1) & "\"
                saveAttAs(1) = saveAttAs(1) & Left(mai.Attachments.item(intAttCount).filename, InStrRev(mai.Attachments.item(intAttCount).filename, ".") - 1)
                saveAttAs(2) = "_ver-" & verNumber
                saveAttAs(3) = Right(mai.Attachments.item(intAttCount).filename, Len(mai.Attachments.item(intAttCount).filename) - InStrRev(mai.Attachments.item(intAttCount).filename, ".") + 1)
                DOSFile = Dir(Join(saveAttAs, ""))
                Do While DOSFile <> ""
                    'That file name found so increment affix
                    verNumber = verNumber + 1
                    saveAttAs(2) = "_ver-" & verNumber
                    DOSFile = Dir(Join(saveAttAs, ""))
                Loop
                att.SaveAsFile Join(saveAttAs, "")
                att.Delete
                mai.Body = mai.Body & vbCrLf & "<file://" & Join(saveAttAs, "") & ">"
                mai.Save
            End If
        End If
    Next
 
End Sub

Open in new window

ASKER CERTIFIED SOLUTION

Chris Bottomley

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial

SOLUTION

David Lee

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial

FlorisMK

ASKER

Chris, I'm flabbergasted that I somehow overlooked the Type property. Just tested this in my implementation and it *is* in fact that simple. Type = olOLE for embedded pictures in RTF messages in 2003, which is all I need for the implementation. Excellent!

BlueDevilFan, points for you as well for concisely pointing out the Type property. Less points though, because your answer is limited to 2007 (though it works in 2003 as well) and you omit the olOLE value.

Chris Bottomley

Glad we could help

Chris

FlorisMK

ASKER

Celebrated too soon. In an HTML mail, attachments and embedded images both have type olByValue. Still no solution... :-((

Chris Bottomley

HAve just looked at an HTML mail with attachments and embedded images. The attachment count equals actual attachments therefore it may be that a solution can be based off type in association with the mail bodyformat.

Chris

Chris Bottomley

I'm talking rubbish aren't I!

I see the problem don't know of a solution as yet but i'll think on it anyway.

Chris

FlorisMK

ASKER

Not rubbish as such but... well, okay, rubbish :-)

If you come across a solution, I'd love to hear about it!

David Lee

Try this. Once again it's only for Outlook 2007.

Sub TestAttachmentType(Item As Outlook.MailItem)
    Dim olkAttachment As Outlook.Attachment
    For intIndex = Item.Attachments.count To 1 Step -1
        Set olkAttachment = Item.Attachments.Item(intIndex)
        If IsEmbeddedAttachment(olkAttachment) Then
            olkAttachment.SaveAsFile strFolder & olkAttachment.FILENAME
            olkAttachment.Delete
        End If
    Next
    Set olkAttachment = Nothing
End Sub

Function IsEmbeddedAttachment(olkItem As Outlook.Attachment) As Boolean
    Dim olkProp As Outlook.PropertyAccessor, strTemp As String
    Set olkProp = olkItem.PropertyAccessor
    strTemp = olkProp.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x3712001E")
    If InStr(1, strTemp, "@") > 0 Then
        IsEmbeddedAttachment = True
    Else
        IsEmbeddedAttachment = False
    End If
    Set olkProp = Nothing
End Function

Open in new window

FlorisMK

ASKER

That looks promising for 2007. I wonder if this will diffferentiate between embedded images and attachments whose file icon is embedded in the body?

David Lee

Don't know. Only RTF formatted messages would have a file attachment embedded in the body and I NEVER use RTF. It is a Microsoft only format that is not usually supported by other mail clients.

FlorisMK

ASKER

That's what I've been trying to tell my client :-D