VBA Attachments Probleme

Home-›Foren-›Outlook-›Outlook VBA-›VBA Attachments Probleme

1 Antwort anzeigen (von insgesamt 1)
  • Autor
    Beitrag
  • #47316
    Unbekannt
    Teilnehmer

    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://imageshack.us][img=http://img99.imageshack.us/img99/8015/fehlerwc6.jpg][/url]
    [url=http://g.imageshack.us/img99/fehlerwc6.jpg

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

1 Antwort anzeigen (von insgesamt 1)

-

Hat Ihnen der Beitrag gefallen?

1 Stern2 Sterne3 Sterne4 Sterne5 Sterne (Keine Bewertung vorhanden)
Loading...