Outlook Anhänge entfernen

Es kommt immer wieder von das Anhänge von Emails nicht mehr benötigt werden. Die E-Mail aber nicht gelöscht werden soll. Die Anhänge lassen sich aber nur bei geöffneter E-Mail löschen. Daher dieses kleine VBA-Script.

VBA-Code

Public Sub DeleteSelectedMailItemsAttachment()
  Dim objFolder As MAPIFolder
  Dim objMailSel As MailItem
  Dim objSelection As Selection
  Dim myattachments As Attachment
  Dim i%, j%
  'On Error Resume Next
  'geht leider nur mit einer Mail
  Select Case Application.ActiveWindow.Class
  Case olExplorer
    Set objFolder = Application.ActiveExplorer.CurrentFolder
    If objFolder.DefaultMessageClass = "IPM.Note" Then
      Set objSelection = Application.ActiveExplorer.Selection
      If objSelection.Count = 0 Then
        'MsgBox "Es sind keine Mails ausgewählt !"
      Else
        For Each objMailSel In objSelection
          DoEvents
          i = objMailSel.Attachments.Count
          While i > 0
            objMailSel.Attachments.Remove i
            DoEvents
            i = i - 1
          Wend
        Next
      End If
      Set objSelection = Nothing
    Else
      'MsgBox "Im Ordner '" & objFolder.Name & "' sind keine Mails enthalten!"
    End If
    Set objFolder = Nothing

  Case olInspector
      With Application.ActiveInspector
        If .CurrentItem.Class = olMail Then
          Set objMailSel = .CurrentItem
          i = objMailSel.Attachments.Count
          While i > 0
            objMailSel.Attachments.Remove i
            i = i - 1
          Wend
          Set objMailSel = Nothing
        Else
          'MsgBox "Es ist keine Mail aktiv !"
        End If
      End With
  End Select
End Sub

xccc

Hauptmenü

Anmeldeformular