Outlook - Automatisierte Mailverarbeitung mit VBA-Makros

'------snipp Makro zur Administrator-Mail-Nachbehandlung 

Option Explicit 

Public Sub FormatAdminMsg() 

'Drei Konstanten für die notify-Mails von Administrator.de 

Const ADMIN_NSender = "notify@administrator.de" 

Const ADMIN_NPrefix = "[administrator.de] Auf den Beitrag " 

Const ADMIN_NSuffix = " wurde geantwortet." 

'Drei Konstanten für die message-Mails von Administrator.de 

Const ADMIN_MSender = "message@www.administrator.de" 

Const ADMIN_MPrefix = "Das administrator.de-Mitglied " 

Const ADMIN_MSuffix = " hat Ihnen diese Nachricht zugeschickt." 

'Der einfallsreiche Titel einer Notiz, die geschrieben wird 

Const ADMIN_NOTIFY = "Administrator-Messages" 

'Der einfallsreiche Titel einer Textdatei, die geschrieben wird 

Const ADMIN_TEXTFILE = "AdminMsg.txt" 

'Deklarationen 

'zuerst für Outlook selbst und den Namespace... ohne die beiden geht nichts. 

Dim MyOLApp As Application 

Dim myNameSpace As NameSpace 

'Ein paar Ordner brauche ich..drei zum Spielen.... 

Dim FolderAdminCopy, FolderAdminInbox, FolderAdminProper As MAPIFolder 

' ...und ein paar Ordner zur Orientierung: Posteingang und den "Obersten" 

Dim myInbox As MAPIFolder, FolderRoot, FolderAdminNotes As MAPIFolder 

'jetzt die kleineren Sachen.. ein Notiz-Object, zwei Mail-Objects 

Dim NoteX As NoteItem 

Dim MailX, MailXCopy As MailItem 

'und ein bisschen Kroppzeug... Zeichen- und Zählveriablen.. 

Dim NoteText$, NewSubject$, NewBody$, notifyCutLen 

Dim i, j, k As Integer 

Dim NoteFound As Boolean 

Dim fs As Object, a 

notifyCutLen = Len(ADMIN_NPrefix) + Len(ADMIN_NSuffix) + 2 

' nun gehts endlich los... 

Set MyOLApp = CreateObject("Outlook.Application") 

Set myNameSpace = MyOLApp.GetNamespace("MAPI") 

'Default-Mailbox nehmen.. manche haben nur eine, andere ein Dutzend 

' die aktive Mailbox laut Profil ist logischerweise der Parent (neudeutsch für "Vadder" vom "Posteingang" 

Set FolderRoot = myNameSpace.GetDefaultFolder(olFolderInbox).Parent 

'nehmen wir mal an, Mails von administrator.de liegen im "Posteingang", siehe "!!!Hint" oben 

Set FolderAdminInbox = myNameSpace.GetDefaultFolder(olFolderInbox) 

'....einen Ordner für Eins-zu-Eins-Kopien anlegen 

Set FolderAdminCopy = CreateFolderIfNotExist("AdminCopy", FolderRoot) 

'....und einen für die nachbearbeiteten "Notifies" und "Messages" 

Set FolderAdminProper = CreateFolderIfNotExist("AdminProper", FolderRoot) 

'....und einen für die Notiz namens "Administrator-Messages", die ich zusätzlich anlege. 

Set FolderAdminNotes = CreateFolderIfNotExist("AdminNotizen", FolderRoot, olFolderNotes) 

' eine Variante, um ein bestimmtes Item zu suchen... die ganze Liste durchwackeln.. 

' hier suche ich eine Notiz, die ADMIN_NOTIFY ("Administrator-Messages") <i>heißt</i>. 

For Each NoteX In FolderAdminNotes.Items 

   Debug.Print "Subject: "; "'" & NoteX.Subject & "#" 

   If StrComp(NoteX.Subject, ADMIN_NOTIFY, vbTextCompare) = 0 Then 

       NoteText = NoteX.Body 

       NoteFound = True 

      Exit For 

   End If 

Next 

If Not NoteFound Then 

   ' wenn noch keine existiert (oder ich zu blöd zum Finden war),  

   'dann eine neue Notiz anlegen 

   Set NoteX = FolderAdminNotes.Items.Add(olNoteItem)  

   NoteX.Body = ADMIN_NOTIFY       

   ' die erste Zeile des Body-Textes wird automatisch zum "Namen" der Notiz 

   NoteX.Save 

   Debug.Print "FolderAdminNotes.Subject "; NoteX.Subject 

End If 

Debug.Print NoteText 

Set fs = CreateObject("Scripting.FileSystemObject") 

Set a = fs.CreateTextFile(Environ$("temp") & "" & ADMIN_TEXTFILE, True) 

For Each MailX In FolderAdminInbox.Items 

   ' wenn eine Mail vom "Message"-Sender  message@administrator.de... 

   If StrComp(MailX.SenderName, ADMIN_MSender, vbTextCompare) = 0 Then 

         j = InStr(1, MailX.Body, ADMIN_MPrefix, vbTextCompare) 

         k = InStr(j + 2, MailX.Body, ADMIN_MSuffix, vbTextCompare) 

         NewBody = Mid(MailX.Body, j + Len(ADMIN_MPrefix), k - j - Len(ADMIN_MPrefix)) 

         Set MailXCopy = MailX.Copy   '1:1-Kopie in den Ordner "Admincopy" 

         MailXCopy.Move FolderAdminCopy 

         MailX.Body = NewBody 

         MailX.Subject = MailX.SentOn & " von " & NewBody 

         MailX.Save 

         MailX.Move FolderAdminProper 

         Debug.Print NewBody 

         NoteX.Body = NoteX.Body & vbCrLf + MailX.Subject 

         NoteX.Save 

   End If 

   ' wenn eine Mail vom "Notify"-Sender  notify@administrator.de... 

   If StrComp(MailX.SenderName, ADMIN_NSender, vbTextCompare) = 0 Then 

     If StrComp(Left(MailX.Subject, Len(ADMIN_NPrefix)), ADMIN_NPrefix) = 0 And _ 

        StrComp(Right(MailX.Subject, Len(ADMIN_NSuffix)), ADMIN_NSuffix) = 0 Then 

         NewSubject = Mid(MailX.Subject, Len(ADMIN_NPrefix) + 2, _ 

                               Len(MailX.Subject) - notifyCutLen) 

         ' die ganzen "RE: "s brauch ich nicht.. weg damit 

         While StrComp(Left(NewSubject, 4), "RE: ", vbTextCompare) = 0 

           NewSubject = Mid(NewSubject, 5) 

         Wend 

        ' noch eben schnell die HTML-Maskierungen wegnehmen aus den Mails: 

         NewSubject = Replace(NewSubject, "ä", "ä") 

         NewSubject = Replace(NewSubject, "ü", "ü") 

         NewSubject = Replace(NewSubject, "ö", "ö") 

         NewSubject = Replace(NewSubject, "Ä", "Ä") 

         NewSubject = Replace(NewSubject, "Ü", "Ü") 

         NewSubject = Replace(NewSubject, "Ö", "Ö") 

         NewSubject = Replace(NewSubject, "ß", "ß") 

         Debug.Print MailX.SentOn & " " & "'" & NewSubject & "'" 

         j = InStr(1, MailX.Body, "http://www.administrator.de/", vbTextCompare) 

         k = InStr(j + 20, MailX.Body, "um die Antworten zu lesen.", vbTextCompare) 

         NewBody = Mid(MailX.Body, j, k - j - 2) 

         Set MailXCopy = MailX.Copy   '1:1-Kopie in den Ordner "Admincopy" 

         MailXCopy.Move FolderAdminCopy 

         MailX.Body = NewBody 

         MailX.Subject = NewSubject 

         MailX.Save 

         MailX.Move FolderAdminProper 

         Debug.Print NewBody 

         a.Writeline NewSubject 

     End If 

   End If 

Next 

a.Close 

Set FolderAdminCopy = Nothing 

Set FolderAdminInbox = Nothing 

Set FolderAdminNotes = Nothing 

Set FolderAdminProper = Nothing 

Set FolderRoot = Nothing 

Set myNameSpace = Nothing 

End Sub 

Private Function CreateFolderIfNotExist(strFolderName As String, _ 

            ByVal ParentFolder As MAPIFolder, _ 

            Optional DefaultItemType As Long) As MAPIFolder 

On Error GoTo createIt 

Set CreateFolderIfNotExist = ParentFolder.Folders(strFolderName) 

Exit Function 

createIt: 

Debug.Print Hex$(Err.Number) & " " & Err.Description 

IF StrComp(Hex$(Err.Number), "8004010F", vbTextCompare) = 0 then 

    ' ....wegen der Lesbarkeit vergleiche ich hier:  

    '.....If Hex$(Err.Number) = "8004010F" Then 

    ' der "echte" Fehlercode ist  -2147221233 == 0x8004010F  

    '..so (in Hex) kann ich den wiedererkennen. Bedeutet: Object nicht gefunden 

    Err.Clear 

    Debug.Print DefaultItemType  

    ' wenn kein Type als Parameter mitgegeben, dann als Type "Mails" setzen 

   If DefaultItemType = 0 Then DefaultItemType = olFolderInbox 

   On Error Resume Next 

   Set CreateFolderIfNotExist = _  

       ParentFolder.Folders.Add(strFolderName, DefaultItemType)  ', olMail) 

Else 

    'was immer sonst passieren mag.. ich habs nicht abgefangen..  

    'hier also Crash & Burn... 

    Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext 

End If 

' falls das Ordner-Neuanlegen in die Grütze geht... 

If Err.Number <> 0 Then Err.Raise Err.Number    

Resume Next 

End Function 

'------snipp Makro zur Administrator-Mail-Nachbehandlung