VBA Attachments Probleme

Hall ich versuche gerade meine Anhänge auszulagern, mit diesem VBA Script_

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: https://www.mailhilfe.de/frage27782.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 = \“c:\\test\“
\’…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)

\’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: \“, \“c:\\test\“)

\’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 & _
\“\“ & 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 & \“

\“

\’sichere vorhandene Anhänge ins Filesystem
For i = 1 To myAnhänge.Count

\’check, ob schon erledigt – Abbruch!
If InStr(myAnhänge(i).FileName, schonerledigt) > 0 Then
istschonerledigt = True
Exit For
End If

\’§§§ Namen definieren (Blacklist-Zeichen werden einfach weggelassen – siehe OnlyValidChars) Whitelist wäre besser!
\’ggf. hier eingreifen, um abweichend zu verfahren (z.B. Ordner je Jahr anlegen, oder je Sender/Empfaenger/Subject…)…
externername = myOrt & Format(myteil.CreationTime, \“yyyymmdd_hhnnss_\“) & i & \“_\“ & OnlyValidChars(myAnhänge(i).FileName)
If Trim(myAnhänge(i).FileName) = \“\“ Then
externername = externername & \“.msg\“
End If
If InStr(1, externername, \“.\“) < 1 Then externername = externername & \".txt\" End If \'Maximallänge Name checken If Len(externername) > 255 Then
\‘ kürzen…
externername = Left(externername, 250) & Right(externername, 4)
End If

\’und Anhänge wegsichern zum …pfad/timestamp-originalname…
myAnhänge(i).SaveAsFile externername

\’Ort\\Name in die Nachricht eintragen – das file:/// ermöglicht i.d.R. öffnen auf anklicken in Outlook
newbody = newbody & vbCrLf & \“

• Datei: \“ & myAnhänge(i).FileName & \“ (\“ & externername & \“)

\“

Next i

If istschonerledigt = False Then

\’dann lösche anschliessend alle Anhänge…
While myAnhänge.Count > 0

\’§§§ Anhang entfernen (Outlook 2002/2003) – ggf. in Kommentar, wenn man ihn im Outlook behalten will
myAnhänge.Remove 1
Wend

\’Anhang mit Infos anlegen
newbody = newbody & 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

Lieder bekomme ich beim Ausführen folgende Fehlermeldung:

[url=http://g.imageshack.us/img99/fehlerwc6.jpg

http://img99.imageshack.us/my.php?image=fehlerwc6.jpg