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://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...