Benutzer:Rdiez/OutlookAttachmentRemover

Dies sind die persönlichen Benutzerseiten von rdiez, bitte nicht verändern! Ausnahmen sind nur einfache Sprachkorrekturen wie Tippfehler, falsche Präpositionen oder Ähnliches. Alles andere bitte nur dem Benutzer melden!

If you are using Microsoft Outlook, chances are that you are in a corporation and your mailbox has a limited size. Therefore, you need to delete e-mails often, or at least the biggest file attachments.

In Mozilla Thunderbird, when you delete an e-mail attachment, the e-mail still remembers the attachment's filename, so that you know that an attachment was there in the past. However, in Microsoft Outlook, if you delete an attachment, it's gone without trace. Later on, you don't know if an e-mail ever had an attachment, or who sent you a particular file.

This script emulates Thunderbird's behaviour in Outlook. Usage scenarios are:

1. You open an e-mail, press the button associated to this script, and then attachments are gone, but text lines like the following are automatically prepended to the e-mail:
          [Attachment deleted: myfile1.zip]
          [Attachment deleted: myfile2.zip]
   The e-mail is marked as modified but not automatically saved. You can then discard changes and get your attachments back if you wish.
   This is the scenario I had in mind when I wrote this script.
2. You can also mark several e-mails without opening them and do the same as for case (1).
   If there is more than one e-mail, you'll get a confirmation dialog box.
   There are 2 different ways to approach this task:
   1. You don't open the e-mails.
      The script would need to save changes immediately. Otherwise, all changes will be lost without confirmation when you close Outlook. I chose not do to this, because it's risky, the user can lose important data.
   2. Open all e-mails and modify them.
      This is similar to scenario (1), but may leave behind many open e-mails. Every time the user tries to close one, he'll be prompt in ordre to save or discard the changes. This is the option I chose to implement.

It would have been better to decide between (1) and (2.2) based on whether the user has selected e-mails on a list, or whether the user has opened a single e-mail. However, I don't know how to distinguish those scenarios yet in VBA code.

This script has been tested with Outlook 2010.

In order to install this script in your Outloook, you need to enable the developer tools ribbon, copy the source code below to the default project, and then create a ribbon icon for it on all the ribbons you would like to access this script from.

Public Sub DeleteAttachmentsButLeaveTheirFilenamesBehind()

    On Error GoTo ErrorHandler:

    Dim objOL As Outlook.Application
    Set objOL = CreateObject("Outlook.Application")
    
    Dim objSelection As Outlook.Selection
    Set objSelection = objOL.ActiveExplorer.Selection
    
   
   ' In the first pass, we just count the number of attachments to delete,
   ' in order to ask for confirmation if necessary.

    Dim emailCount As Integer
    Dim attachmentCount As Integer
    Dim objMsg1 As MailItem

    For Each objMsg1 In objSelection
        If objMsg1.Class = olMail Then
        
            emailCount = emailCount + 1
        
            Dim objAttachments1 As Outlook.Attachments
            Set objAttachments1 = objMsg1.Attachments
            
            Dim msgAttachmentCount1 As Long
            msgAttachmentCount1 = objAttachments1.Count
            
            attachmentCount = attachmentCount + objAttachments1.Count
        End If
    Next
    
    Dim msgboxRes As VbMsgBoxResult
    
    If emailCount = 0 Then
      msgboxRes = MsgBox("No e-mails selected.", vbOKOnly + vbCritical)
      Exit Sub
    End If
    
    If attachmentCount = 0 Then
      msgboxRes = MsgBox("No attachments found in " & emailCount & " e-mail(s).", vbOKOnly + vbCritical)
      Exit Sub
    End If
    
    If emailCount > 1 Then
      msgboxRes = MsgBox("Would you like to remove " & attachmentCount & " attachment(s) from " & emailCount & " e-mail(s)?", vbYesNo + vbQuestion + vbDefaultButton2)
      If msgboxRes = vbNo Then
          Exit Sub
      End If
    End If

    
    ' In the second pass, we remove the attachments. Note that the e-mails could have changed in the meantime.
    ' However, it's rare to hit that window of opportunity.
    
    Dim deletedMsg As String
    Dim objMsg2 As MailItem

    For Each objMsg2 In objSelection
        If objMsg2.Class = olMail Then
        
            ' Open all e-mails we are going to change. Otherwise, if the user closes Outlook, any changes will be discarded.
            ' See the big comment above for more information.
            objMsg2.Display
            
            Dim objAttachments2 As Outlook.Attachments
            Set objAttachments2 = objMsg2.Attachments
            
            Dim msgAttachmentCount2 As Long
            msgAttachmentCount2 = objAttachments2.Count
            
            If msgAttachmentCount2 > 0 Then
                deletedMsg = ""

                Dim i As Long
                For i = msgAttachmentCount2 To 1 Step -1
                    deletedMsg = "[Attachment deleted: " & objAttachments2.Item(i).FileName & "]" & vbCrLf & deletedMsg
                    objAttachments2.Item(i).Delete
                Next i
                deletedMsg = deletedMsg & vbCrLf
               
                Dim objInsp As Outlook.Inspector
                Set objInsp = objMsg2.GetInspector
                
                Dim objDoc As Object  ' I haven't found out yet how to reference the Word classes from an Outlook 2010 VBA project,
                                      ' so I had to use a generic 'Object' type instead. The WdProtectionType constants below
                                      ' are not defined either, so I had to use their numeric values.
                Set objDoc = objInsp.WordEditor
                
                ' This was an attempt to execute the "EditMessage" command on thee-mail,
                ' but the call to 'Unprotect' below fails on my Outlook 2010:
                
                ' If you open an e-mail from the 'Drafts' folder, you can change it straight away. Otherwise, you normally
                ' get a write-protected view, where you can delete attachments (!) but not modify the text.
                ' In order to lift the protection, I tried a number of ways:
                '  - ActiveWindow.View.ReadingLayout = False
                '  - objDoc.UnProtect
                '  - objDoc.Protect WdProtectionType.wdNoProtection
                '  - objOL.ActiveInspector.CommandBars.ExecuteMso ("EditMessage")
                ' None of the above worked, but I did find a method to remove the protection, see below:
                
                If objDoc.ProtectionType = 3 Then  ' Value 3 means WdProtectionType.wdAllowOnlyReading.
                  objInsp.CommandBars.ExecuteMso ("EditMessage")
                End If
                
                If True Then
                  ' This method seems to work for all possible e-mail formats.
                  objDoc.Characters(1).InsertBefore deletedMsg
                Else
                  ' Old method, now unused, only kept for future reference.
                  If objMsg2.BodyFormat = olFormatHTML Then
                    ' Here we should do HTML escaping.
                    deletedMsg = Replace(deletedMsg, vbCrLf, "<br/>")
                    objMsg2.HTMLBody = "<p>" & deletedMsg & "</p>" & objMsg2.HTMLBody
                  ElseIf objMsg2.BodyFormat = olFormatRichText Then
                    ' I did not manage to edit the RTF format directly yet, because objMsg2.RTFBody
                    ' is not a string, but an array of bytes.
                    Err.Raise vbObjectError, , "Modifying an e-mail in RTF format not supported yet."
                  ElseIf objMsg2.BodyFormat = olFormatPlain Then
                    objMsg2.Body = deletedMsg & objMsg2.Body
                  Else
                    Err.Raise vbObjectError, , "Unknown message text format."
                  End If
                End If
            End If
        End If
    Next
    
    Exit Sub
    
ErrorHandler:
    
    Dim errMsgboxRes As VbMsgBoxResult
    errMsgboxRes = MsgBox("Error: " & Err.Description, vbOKOnly + vbCritical)
  
End Sub