Sub OutlookAnhaengeSpeichern() 'Makro für Outlook 2003 - Anhänge selektierter Mails in Filesystem extrahieren und lediglich Verweis 'auf Dateianlagen hinterlegen 'http://galupki.de/content/index.php?wiki=WindowsTools&begriff=Outlook%20Anhaenge%20extrahieren '05.10.-14.10.2008 juergen galupki - http://galupki.de/kontakt/readme-kontakt-lizenz.html 'Quelle/Grundlage: http://www.mailhilfe.de/frage_VBA+-+Anh%E4nge+aus+mails+expotieen_27782.html 'geändert/ergänzt 'installieren: '- in Outlook 2003 Alt+F11 '- Doppelklick links auf Modul1 '- alles reinkopieren '- nach §§§ suchen und Zeilen nach Wunsch ggf. anpassen (zumindest den Speicher-Pfad) '- das Makro z.B. auf einer Symbolleiste platzieren (oder jeweils Alt+F8...) 'Sicherheitsabfrage! ggf. das makro selbst für den eigenen Rechner signieren mit Zertifikat 'todo: Nur bestimmte Typen von Dateien speichern? Nur ab bestimmter Größe? MailItem oder je Anhang? 'todo: verschluesselte Mails/Anhänge? Andere Systematik (Ordner je Sender/Jahr/Monat/...)...? ' 'FUNKTIONSWEISE ' '- verarbeite selektierte Nachrichten mit Anhaengen '- hat die Mail eine Anlage mit Namen (schonerledigt=ExtrahierteAnhaenge.html) tue nichts (mehr) für diese Mail '- sonst je Anhang: Schreibe als Datei ins Filesystem, merke Namen dieser Datei '- lösche alle alten (gesicherten) Anhänge aus der Mail '- schreibe Mailbody (als Nur-Text) noch dazu '- füge neuen Anhang (schonerledigt=ExtrahierteAnhaenge.html) hinzu (enthält Verweise auf die Dateien) ' 'WENN es als Script für den Outlook-Regeleditor dienen soll statt einfachem Sub wie folgt: 'Sub CustomMailMessageRule(myteil As Outlook.MailItem) 'myOrt = "d:\user\juergen\Archive\Outlook\Anlagen\" '...ausserdem natürlich diverse dann überflüssige DIMs weg und die Schleife über myOlSel entfällt auch! 'man sollte es dann auch unbedingt signieren (wg. Sicherheitsabfrage) 'Fehlerbehandlung On Error GoTo GetAttachments_err 'Variable Dim myOrt, externername, bodyzeilen As String Dim myOlApp As New Outlook.Application Dim myOlExp As Outlook.Explorer Dim myOlSel As Outlook.Selection Dim myteil As Outlook.MailItem Dim myteils, myAnhänge, myAnhang As Object Dim fsoT, FileT '§§§ WENN ein Anhang mit folgendem Namen existiert DANN tue nix - Name kann hier geaendert werden (.html ist zwingend) schonerledigt = "ExtrahierteAnhaenge.html" '§§§ Hier wird nach dem Ort gefragt wo gespeichert werden soll - muss schon existieren myOrt = InputBox("Speicherort (sollte regelmäßig gesichert werden)", "Anhänge Speichern unter: ", "d:\user\juergen\Archive\Outlook\Anlagen\") 'arbeite die einzelnen Nachrichten ab Set myOlExp = myOlApp.ActiveExplorer Set myOlSel = myOlExp.Selection 'für alle Mails... For Each myteil In myOlSel 'sammeln aller Anhang-Infos newbody = "" istschonerledigt = False '...Anhänge bearbeiten... Set myAnhänge = myteil.Attachments '...wenn überhaupt welche da sind... If myAnhänge.Count > 0 Then '§§§ füge einen Hinweis am Ende der Email ein - ggf. Text ändern... newbody = "" & vbCrLf & _ "" & vbCrLf & _ "" & vbCrLf & _ "Outlook - ins Filesystem ausgelagerte Anhänge - " & myteil.Subject & "" & vbCrLf & _ "
" & vbCrLf & _
          "Sender    " & myteil.SenderEmailAddress & vbCrLf & _
          "To        " & myteil.To & vbCrLf & _
          "Cc        " & myteil.CC & vbCrLf & _
          "Subject   " & myteil.Subject & "" & vbCrLf & _
          "gesendet  " & Format(myteil.CreationTime, "dd.mm.yyyy hh:nn:ss") & ", " & _
          "empfangen " & Format(myteil.ReceivedTime, "dd.mm.yyyy hh:nn:ss") & vbCrLf & _
          "Größe     " & Round(myteil.Size / 1000000, 3) & " MB" & vbCrLf & vbCrLf & _
          "
" & "
" & vbCrLf & _ "

Ausgelagerte Anhänge:

" & vbCrLf & "" & vbCrLf & _ "
" & myteil.Body & vbCrLf & _
             "
" 'Vorsicht: Keine Pruefung auf Maximallaenge anhanginfoname = myOrt & Format(myteil.CreationTime, "yyyymmdd_hhnnss_") & OnlyValidChars(myteil.SenderEmailAddress) & "_" & schonerledigt Set fsoT = CreateObject("Scripting.FileSystemObject") Set FileT = fsoT.CreateTextFile(anhanginfoname, True) FileT.WriteLine (newbody) FileT.Close '...und an die Mail heften... myAnhänge.Add anhanginfoname, _ olByValue, 1, schonerledigt 'gesamte Mail speichern (sichern) ohne alte Anhaenge - mit neuem Anhang (Liste der Anhaenge) myteil.Save '§§§ abspeichern der Mail selbst im reinen Textformat 'WENN der Mailtext selbst nicht mit gespeichert werden soll alles bis einschl. myteil.SaveAs... in Kommentar setzen! 'WENN generell alle Mails extrahiert werden sollen (auch ohne Anhänge) verschiebe Block unmittelbar vor nächstes "Next"... ' externername = myOrt & Format(myteil.CreationTime, "yyyymmdd_hhnnss_") & "Mail_" & OnlyValidChars(Trim(myteil.Subject)) & ".txt" 'Maximallänge checken ' If Len(externername) > 255 Then ' MsgBox (externername) ' externername = Left(externername, 250) & Right(externername, 4) ' End If ' myteil.SaveAs externername, olTXT End If 'ist schon erledigt = false End If 'Anhanege sind vorhanden Next GetAttachments_exit: 'Speicher aufräumen Set myteils = Nothing Set myteil = Nothing Set myAnhänge = Nothing Set myAnhang = Nothing Set myOlApp = Nothing Set myOlExp = Nothing Set myOlSel = Nothing Set FileT = Nothing Set fsoT = Nothing Exit Sub GetAttachments_err: MsgBox "Ein unerwarteter Fehler beim extrahieren der Mail-Anhänge ist aufgetreten:" _ & vbCrLf & "(letzter bearbeiteter Anhang " & externername & ") " _ & vbCrLf & "Macro Name: OutlookAnhaengeSpeichern" _ & vbCrLf & "Error Number: " & Err.Number _ & vbCrLf & "Error Description: " & Err.Description _ , vbCritical, "Error!" Resume GetAttachments_exit End Sub Public Function OnlyValidChars(Text As String) As String 'eine Whitelist wäre sicherlich besser Dim BlackList As String Dim AusgabeText As String Dim l As Long BlackList = "#/\\:*?""'´`=<>|{}+,;!%&^°" & Chr(0) AusgabeText = "" For l = 1 To Len(Text) If InStr(BlackList, Mid$(Text, l, 1)) = 0 Then AusgabeText = AusgabeText & Mid$(Text, l, 1) End If Next 'l OnlyValidChars = AusgabeText End Function