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, "&auml;", "ä")  
         NewSubject = Replace(NewSubject, "&uuml;", "ü")  
         NewSubject = Replace(NewSubject, "&ouml;", "ö")  
         NewSubject = Replace(NewSubject, "&Auml;", "Ä")  
         NewSubject = Replace(NewSubject, "&Uuml;", "Ü")  
         NewSubject = Replace(NewSubject, "&Ouml;", "Ö")  
         NewSubject = Replace(NewSubject, "&szlig;", "ß")  

         Debug.Print MailX.SentOn & " " & "'" & NewSubject & "'"  
         j = InStr(1, MailX.Body, "https://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