Malicious Office (OOXML) — malware analysis report

Attribute VB_Name = "ThisDocument"
Attribute VB_Base = "0{00020906-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True

Attribute VB_Name = "eWorksOutlook"
Option Explicit
Option Private Module

' ==============================================================================
' eWorks GmbH
'
' Dieses Modul enthält Outlook-spezifische Funktionen.
'
' Benötigte Verweise: "Microsoft Outlook xx.x Object Library (MSOUTL.OLB)"
' ==============================================================================

Private Const GWL_HWNDPARENT = (-8)

' Optionen zum Speichern von E-Mails in verschiedenen Modi.
Public Enum EmailSaveModeEnum
    SaveModeAuto
    SaveModeEverything
    SaveModeMailOnly
    SaveModeAttachmentsOnly
End Enum

' Optionen zum Speichern von E-Mails in verschiedenen Formaten.
Public Enum EmailSaveFormatEnum
    SaveFormatAuto
    SaveFormatTxt
    SaveFormatHtml
    SaveFormatRtf
    SaveFormatMsg
    SaveFormatMsgWithoutAttachments
End Enum

' Optionen zum Erzeugen neuer E-Mails
Public Enum EmailCreationModeEnum
    EmailNew
    EmailReplyOrForward
    EmailReply
    EmailForward
End Enum

' Varianten der Signatur
Public Enum SignatureTypeEnum
    SignatureTXT
    SignatureHTML
    SignatureRTF
End Enum

' Name des Moduls (wird vor allem für die Fehlerbehandlung genutzt).
Private Const MODULE_NAME = "eWorksOutlook"

' Name der Outlook-Applikationsklasse.
Private Const OUTLOOK_APPLICATION_CLASS = "Outlook.Application"

' Name der Outlook-Namespace.
Private Const OUTLOOK_NAMESPACE_NAME = "MAPI"

' Standard-Erweiterungen zum Speichern von E-Mails in Dateien
Private Const EMAIL_SAVE_EXTENSION_TXT = ".txt"
Private Const EMAIL_SAVE_EXTENSION_RTF = ".rtf"
Private Const EMAIL_SAVE_EXTENSION_HTML = ".html"
Private Const EMAIL_SAVE_EXTENSION_MSG = ".msg"

' Filter-Strings für den Speichern-unter-Dialog
Private Const EMAIL_SAVE_FILTER_TXT = "Text-Dateien (*.txt),*.txt,Alle Dateien (*.*),*.*"
Private Const EMAIL_SAVE_FILTER_RTF = "RTF-Dateien (*.rtf),*.rtf*,Alle Dateien (*.*),*.*"
Private Const EMAIL_SAVE_FILTER_HTML = "HTML-Dateien (*.htm *.html),*.htm*,Alle Dateien (*.*),*.*"
Private Const EMAIL_SAVE_FILTER_MSG = "Outlook-E-Mail-Dateien (*.msg),*.msg,Alle Dateien (*.*),*.*"

' Anwendungsinterner Name des Suchordners "Alle E-Mail-Elemente"
Public Const ALL_MAIL_ITEMS_SEARCH_FOLDER_NAME = "MS-OLK-AllMailItems"

' Zu verwendende Instanz der Outlook-Applikation - kann optional gesetzt werden.
' (Falls nicht gesetzt, wird versucht, selbst eine Instanz von Outlook zu finden.)
Private meApplication As Outlook.Application

' Cache für die Funktion "GetOutlookVersion", siehe unten.
Private outlookVersionCache As Long

' Fensterklassenname von Outlook
Private Const OUTLOOK_WINDOW_CLASS_NAME = "rctrl_renwnd32"

' Zuletzt betrachtete E-Mail oder anderes Outlook-Item
Public meLastItem As Object

' ==============================================================================
' Prüft, ob sich ein Outlook-Explorer derzeit in der Webseitenansicht befindet.
'
' Optional kann ein "Outlook-Explorer" übergeben werden, der zu verwenden ist -
' falls dieser nicht übergeben wird, wird der derzeit aktiver Explorer genutzt.
' ==============================================================================
Public Function ExplorerIsInWebView( _
    Optional ByVal outlookExplorer As Outlook.Explorer, _
    Optional ByVal showMessages As Boolean = False) As Boolean

    On Error GoTo Catch
    
    Dim result As Boolean
    Dim selectionCount As Long
    
    ' Outlook-Explorer-Instanz besorgen, falls nicht übergeben
    If outlookExplorer Is Nothing Then
    
        Set outlookExplorer = eWorksOutlook.Application.ActiveExplorer
    
    End If
    
    ' Derzeit ist das einzig bekannte Vorgehen das Provozieren eines Fehlers
    On Error Resume Next
    selectionCount = outlookExplorer.Selection.Count
    If Err.Number <> 0 Then
        
        On Error GoTo Catch
        result = True
        
    Else
    
        On Error GoTo Catch
        result = False
        
    End If
    
    ' Ggf. Meldung ausgeben
    If result And showMessages Then
    
        eWorksVBA.ShowWarning "Es kann kein Outlook-Explorer-Fenster ermittelt werden," & _
            " das Outlook-Elemente enthält." & _
            vbNewLine & vbNewLine & _
            "Möglicherweise hilft es, wenn Sie einen anderen Outlook-Ordner auswählen" & _
            " und diese Funktion anschließend erneut ausführen.", _
            "Fehler: Kein Outlook-Ordner mit Outlook-Elementen ausgewählt"
    
    End If
    
Finally:

    On Error GoTo 0
    
    ExplorerIsInWebView = result
    Exit Function
    
Catch:
    
    eWorksVBA.HandleError Err, MODULE_NAME, "ExplorerIsInWebView", True
    GoTo Finally
    
End Function

' ==============================================================================
' Liefert den aktiven Outlook-Ordner der Outlook-Applikation zurück.
'
' Falls aus irgendeinem Grund kein aktiver Outlook-Ordner ermittelt werden kann,
' wird "Nothing" zurückgegeben.
' ==============================================================================
Public Function ActiveFolderGet() As Outlook.MAPIFolder
    
    On Error GoTo Catch
    
    Dim outlookExplorer As Outlook.Explorer
    Dim result As Outlook.MAPIFolder
    
    ' Zugriff auf den aktiven Explorer
    Set outlookExplorer = eWorksOutlook.GetActiveExplorer(False)
    
    ' Aktiver Explorer vorhanden?
    If Not outlookExplorer Is Nothing Then
        
        Set result = outlookExplorer.currentFolder
        Debug.Assert eWorksVBA.Assert(Not result Is Nothing)
    
    End If
    
Finally:

    On Error GoTo 0
    
    Set ActiveFolderGet = result
    Exit Function
    
Catch:

    eWorksVBA.HandleError Err, MODULE_NAME, "ActiveFolderGet", True
    GoTo Finally
    
End Function

' ==============================================================================
' Liefert den Outlook-Ordner zu dem übergebenen Enum-Wert der aktuellen Outlook-Application.
' ==============================================================================
Public Function GetDefaultFolder(ByVal defaultFolderName As OlDefaultFolders) As Outlook.MAPIFolder
    
    On Error GoTo Catch
    
    Dim defaultFolder As Outlook.MAPIFolder
    
    Set defaultFolder = eWorksOutlook.Application.Session.GetDefaultFolder( _
        defaultFolderName)
    Debug.Assert eWorksVBA.Assert(Not defaultFolder Is Nothing)
    
Finally:

    On Error GoTo 0
            
    Set GetDefaultFolder = defaultFolder
    Exit Function
    
Catch:

    eWorksVBA.HandleError Err, MODULE_NAME, "GetDefaultFolder", True
    GoTo Finally
    
End Function

' ==============================================================================
' Erzeugt eine neue Outlook-E-Mail und gibt diese zurück.
'
' Auf Wunsch wird die erzeugte Outlook-E-Mail angezeigt, ansonsten versteckt.
' In jedem Fall wird die erzeugte Outlook-E-Mail zurückgegeben, es sei denn,
' es konnte keine E-Mail erzeugt werden (dann wird "Nothing" zurückgegeben).
'
' Die E-Mail wird a) leer, b) als Antwort oder c) als Weiterleitung erstellt,
' je nachdem, was benötigt wird. Zudem kann d) automatisch entschieden werden,
' ob eine Antwort oder eine Weiterleitung einer bestimmten E-Mail nötig ist:
' eingegangene E-Mails werden beantwortet, ausgegangene hingegen weitergeleitet.
' Die Erkennung, ob eine E-Mail "eingegangen" oder "ausgegangen" ist, läuft ab,
' indem ein Teilstring wie z. B. die eigene Domäne (z. B. "@eworks.de") in der
' Absenderadresse gesucht wird: wenn gefunden, ist es eine ausgegangene E-Mail,
' anderenfalls eine eingegangene E-Mail. Falls keine Domäne spezifiziert ist,
' werden alle E-Mails als ausgegangene E-Mails betrachtet, d. h. weitergeleitet.
'
' Der E-Mail Betreff kann optional auf einen bestimmten Betreff gesetzt werden,
' bzw. falls kein Betreff angegeben, wird dieser bei neuen E-Mail leer sein,
' und bei weitergeleiteten / beantwortetet E-Mails automatisch generiert sein.
' Bei einer Antwort / Weiterleitung kann per "emailSubjectWas" bestimmt werden,
' ob der ursprüngliche Betreff mit "(was: ...)" an das Ende gestellt wird,
' oder völlig überschrieben wird:
'
' E-Mail-Empfänger ("TO", "CC", "BCC") können als Collection übergeben werden,
' oder auch als kommaseparierter String.
'
' Für den Fall, dass es E-Mail-Absender gibt, die der eigenen Domäne angehören,
' aber dennoch einer eingegangenen E-Mail entsprechen (z. B. Kontaktformulare),
' können diese als Ausnahmen bestimmt werden ("ownInternetDomainExceptions").
' Da der Vergleich mit Berücksichtigung von Groß- / Kleinschreibung erfolgt,
' sollten alle Ausnahme-E-Mail-Adressen in Kleinbuchstaben angegeben werden,
' z. B. "kontaktformular@firmenname.de" - nicht in Großbuchstaben oder gemischt.
'
' Wird eine E-Mail beantwortet, so wird diese immer "an Alle" beantwortet.
'
' Die weiterzuleitende / zu beantwortende E-Mail kann entweder definiert werden,
' oder kann (falls keine E-Mail übergeben wird) interaktiv erfragt werden.
' ==============================================================================
Public Function EmailCreate( _
    Optional ByVal showMessages As Boolean = False, _
    Optional ByVal displayEmail As Boolean = True, _
    Optional ByVal emailSubject As String = "", _
    Optional ByVal emailSubjectWas As Boolean = True, _
    Optional ByVal emailBody As String = "", _
    Optional ByVal emailBodyFormat As Outlook.OlBodyFormat = Outlook.OlBodyFormat.olFormatUnspecified, _
    Optional ByVal emailRecipientsTo As Variant, _
    Optional ByVal emailRecipientsCc As Variant, _
    Optional ByVal emailRecipientsBcc As Variant, _
    Optional ByVal emailSignatureName As String = "", _
    Optional ByVal emailAccountName As String = "", _
    Optional ByVal emailCreationMode As EmailCreationModeEnum = EmailCreationModeEnum.EmailNew, _
    Optional ByVal replyOrForwardEmail As Outlook.MailItem = Nothing, _
    Optional ByVal replyOrForwardClearBodyBefore As Boolean = False, _
    Optional ByVal ownInternetDomain As String = "@eworks.de", _
    Optional ByVal ownInternetDomainExceptions As Variant = "kontaktformular@eworks.de", _
    Optional ByVal emailTicketNumber As Long = 0, _
    Optional ByVal emailBodyPS As String = "") As Outlook.MailItem
    
    On Error GoTo Catch
    
    Dim emailRecipients As eWorksCollection
    Dim emailRecipientsIndex As Long
    Dim result As Outlook.MailItem
    Dim outlookRecipient As Outlook.Recipient
    Dim recipientAddress As String
    Dim oldOutlookRecipient As Outlook.Recipient
    Dim oldRecipientAddress As String
    Dim outlookRecipientName As String
    Dim outlookRecipientAddress As String
    Dim outlookRecipientType As Outlook.OlMailRecipientType
    Dim emailSenderAddress As String
    Dim subjectPrefix As String
    Dim emailRecipientIterator As Variant
    Dim emailRecipientString As String
    Dim emailRecipientName As String
    Dim emailRecipientEmailAddress As String
    Dim ownInternetDomainExceptionsString As String
    Dim outlookRecipientString As String
    Dim wordDocument As Object 'As Word.Document
    Dim wordParagraph As Object
    
    ' Parameter aufbereiten & prüfen
    emailSignatureName = Trim$(emailSignatureName)
    emailAccountName = Trim$(emailAccountName)
    ownInternetDomain = Trim$(ownInternetDomain)
    emailSubject = Trim$(emailSubject)
    Debug.Assert eWorksVBA.Assert( _
        emailBodyFormat = Outlook.OlBodyFormat.olFormatPlain Or _
        emailBodyFormat = Outlook.OlBodyFormat.olFormatHTML Or _
        emailBodyFormat = Outlook.OlBodyFormat.olFormatRichText Or _
        emailBodyFormat = Outlook.OlBodyFormat.olFormatUnspecified)
    Debug.Assert eWorksVBA.Assert( _
        emailCreationMode = EmailCreationModeEnum.EmailNew Or _
        emailCreationMode = EmailCreationModeEnum.EmailReply Or _
        emailCreationMode = EmailCreationModeEnum.EmailForward Or _
        emailCreationMode = EmailCreationModeEnum.EmailReplyOrForward)
    Debug.Assert eWorksVBA.Assert(emailTicketNumber >= 0)
        
    ' E-Mail-Empfänger normalisieren
    If IsMissing(emailRecipientsTo) Then
        Set emailRecipientsTo = New eWorksCollection
    ElseIf Not IsObject(emailRecipientsTo) Then
        Set emailRecipientsTo = eWorksString.SplitString(emailRecipientsTo)
    ElseIf emailRecipientsTo Is Nothing Then
        Set emailRecipientsTo = New eWorksCollection
    End If
    Debug.Assert eWorksVBA.Assert(TypeOf emailRecipientsTo Is eWorksCollection)
    
    If IsMissing(emailRecipientsCc) Then
        Set emailRecipientsCc = New eWorksCollection
    ElseIf Not IsObject(emailRecipientsCc) Then
        Set emailRecipientsCc = eWorksString.SplitString(emailRecipientsCc)
    ElseIf emailRecipientsCc Is Nothing Then
        Set emailRecipientsCc = New eWorksCollection
    End If
    Debug.Assert eWorksVBA.Assert(TypeOf emailRecipientsCc Is eWorksCollection)
    
    If IsMissing(emailRecipientsBcc) Then
        Set emailRecipientsBcc = New eWorksCollection
    ElseIf Not IsObject(emailRecipientsBcc) Then
        Set emailRecipientsBcc = eWorksString.SplitString(emailRecipientsBcc)
    ElseIf emailRecipientsBcc Is Nothing Then
        Set emailRecipientsBcc = New eWorksCollection
    End If
    Debug.Assert eWorksVBA.Assert(TypeOf emailRecipientsBcc Is eWorksCollection)
    
    ' Keine Ausnahmen angegeben? => Leere Liste erzeugen, ist später einfacher
    Debug.Assert eWorksVBA.Assert(VarType(ownInternetDomainExceptions) = vbString Or _
        TypeOf ownInternetDomainExceptions Is eWorksCollection)
    If VarType(ownInternetDomainExceptions) = vbString Then
        ownInternetDomainExceptionsString = ownInternetDomainExceptions
        Set ownInternetDomainExceptions = New eWorksCollection
        ownInternetDomainExceptions.Deserialize ownInternetDomainExceptionsString
    End If
    
    ' Wird eine E-Mail benötigt, auf der aufgebaut werden kann?
    If emailCreationMode = EmailCreationModeEnum.EmailReply Or _
        emailCreationMode = EmailCreationModeEnum.EmailForward Or _
        emailCreationMode = EmailCreationModeEnum.EmailReplyOrForward Then
        
        ' Keine E-Mail angegeben? => Versuchen, E-Mail interaktiv zu ermitteln
        If replyOrForwardEmail Is Nothing Then
            Set replyOrForwardEmail = eWorksOutlook.GetActiveEmail(showMessages)
        End If
        
        ' Immer noch keine E-Mail angegeben? => raus hier
        If replyOrForwardEmail Is Nothing Then
            GoTo Finally
        End If
    
    End If
    Debug.Assert eWorksVBA.Assert(Not replyOrForwardEmail Is Nothing Or _
        emailCreationMode = EmailCreationModeEnum.EmailNew)
        
    If emailCreationMode = EmailCreationModeEnum.EmailReplyOrForward Then
    
        ' Fallunterscheidung: EXCHANGE-Empfänger?
        If StrComp(replyOrForwardEmail.Sender.Type, "EX", VbCompareMethod.vbTextCompare) = 0 Then
        
            ' Ausgegangene E-Mail => E-Mail weiterleiten
            emailCreationMode = EmailCreationModeEnum.EmailForward
        
        Else
    
            ' Sender der E-Mail ermitteln
            emailSenderAddress = LCase$(Trim$(replyOrForwardEmail.SenderEmailAddress))
            Debug.Assert eWorksVBA.Assert(emailSenderAddress <> "")
            Debug.Assert eWorksVBA.Assert(InStr(1, emailSenderAddress, "@") > 0)
            Debug.Assert eWorksVBA.Assert(InStr(1, emailSenderAddress, " ") <= 0)
        
            ' Fallunterscheidung: eigene Absender-Domäne angegeben oder nicht?
            If ownInternetDomain <> "" Then
        
                ' Fallunterscheidung: entweder ist die E-Mail eine ausgegangene E-Mail,
                ' was daran erkannt wird, dass der Absender der eigene Absender ist,
                ' oder es handelt sich (anderenfalls) um eine eingegangene E-Mail
                If InStr(1, emailSenderAddress, ownInternetDomain, VbCompareMethod.vbTextCompare) > 0 Then
                
                    ' Wahrscheinlich ausgegangene E-Mail, jedenfalls taucht die eigene
                    ' Internet-Domäne in der Absenderadresse der E-Mail auf. Nun prüfen,
                    ' ob vielleicht Ausnahmen angegeben sind, und auf Ausnahme prüfen:
                    Debug.Assert eWorksVBA.Assert(Not ownInternetDomainExceptions Is Nothing)
                    If ownInternetDomainExceptions.ContainsValue(emailSenderAddress) Then
                        ' Doch keine ausgegangene E-Mail, sondern eine der Ausnahmen -
                        ' das heißt eigentlich eine eingegangene E-Mail => antworten
                        emailCreationMode = EmailCreationModeEnum.EmailReply
                    Else
                        ' Tatsächlich eine ausgegangene E-Mail => E-Mail weiterleiten
                        emailCreationMode = EmailCreationModeEnum.EmailForward
                    End If
                Else
                    ' Eingegangene E-Mail => E-Mail beantworten
                    emailCreationMode = EmailCreationModeEnum.EmailReply
                End If
                
            Else
                ' Unklar, ob ein- oder ausgegangen (mangels Absender-Domäne) =>
                ' => E-Mail in diesem Fall generell weiterleiten (siehe oben)
                emailCreationMode = EmailCreationModeEnum.EmailForward
            End If
        End If
    End If
    Debug.Assert eWorksVBA.Assert( _
        emailCreationMode = EmailCreationModeEnum.EmailNew Or _
        emailCreationMode = EmailCreationModeEnum.EmailReply Or _
        emailCreationMode = EmailCreationModeEnum.EmailForward)
    
    ' Neue E-Mail erzeugen - Fallunterscheidung anhand der Art und Weise
    If emailCreationMode = EmailCreationModeEnum.EmailNew Then
    
        ' Neue E-Mail erzeugen
        Set result = eWorksOutlook.Application.CreateItem(Outlook.olMailItem)
        subjectPrefix = ""
        
    ElseIf emailCreationMode = EmailCreationModeEnum.EmailReply Then
    
        ' E-Mail beantworten
        Set result = replyOrForwardEmail.ReplyAll
        
        ' Alle "TO"-Empfänger (abgesehen vom ursprünglichen Sender) entfernen
        For Each outlookRecipient In result.Recipients
        
            If outlookRecipient.Type = OlMailRecipientType.olTo Then
                
                recipientAddress = eWorksOutlook.RecipientGetAddress(outlookRecipient)
            
                If StrComp(recipientAddress, emailSenderAddress, VbCompareMethod.vbTextCompare) <> 0 Then
               
                    outlookRecipient.Delete
               
                End If
            
            End If
        
        Next
        
        subjectPrefix = "AW: "
    
    ElseIf emailCreationMode = EmailCreationModeEnum.EmailForward Then
    
        ' E-Mail weiterleiten
        Set result = replyOrForwardEmail.Forward
        subjectPrefix = "WG: "
        
        ' Bisherige Empfänger übernehmen
        For Each oldOutlookRecipient In replyOrForwardEmail.Recipients
                    
            ' Folgendes funktioniert leider nicht, obwohl es müsste
            ' (denn es geht manchmal die .Address verloren, die wir aber brauchen)
            'result.Recipients.Add oldOutlookRecipient
            
            outlookRecipientString = eWorksOutlook.RecipientNormalizeAsString(oldOutlookRecipient)
            result.Recipients.Add outlookRecipientString
            
        Next
        
    Else
        Debug.Assert eWorksVBA.Assert(False)
    End If
    ' Zu diesem Zeitpunkt muss in jedem Fall eine E-Mail vorliegen
    Debug.Assert eWorksVBA.Assert(Not result Is Nothing)
    
    ' Sicherheitshalber alle Empfänger zum ersten Mal auflösen
    If result.Recipients.Count > 0 Then
        result.Recipients.ResolveAll
    End If

    ' Durch alle Empfänger iterieren und ggf. normalisieren
    For Each outlookRecipient In result.Recipients
    
        ' Empfänger normalisieren
        eWorksOutlook.RecipientNormalize result, outlookRecipient
    
        ' Empfängername und -adresse und -typ auslesen
        'outlookRecipientName = Trim$(outlookRecipient.Name)
        'outlookRecipientAddress = Trim$(eWorksOutlook.RecipientAddressGet(outlookRecipient))
        'outlookRecipientType = outlookRecipient.Type
        
        ' Alten Empfänger aus der E-Mail entfernen
        'outlookRecipient.Delete
        'Set outlookRecipient = Nothing
        
        ' Neuen Empfänger hinzufügen
        'Set outlookRecipient = result.Recipients.Add(outlookRecipientName & _
        '    " <" & LCase$(outlookRecipientAddress) & ">")
        'outlookRecipient.Type = outlookRecipientType
            
    Next
    
    ' Sicherheitshalber alle Empfänger zum zweiten Mal auflösen
    If result.Recipients.Count > 0 Then
        result.Recipients.ResolveAll
    End If
    
    ' Durch alle drei Empfängerlisten iterieren (sofern angegeben): TO, CC oder BCC
    For emailRecipientsIndex = 1 To 3
    
        ' Zugriff auf die Empfängerliste (TO, CC oder BCC)
        Set emailRecipients = Nothing
        Select Case emailRecipientsIndex
        Case 1
            Set emailRecipients = emailRecipientsTo
        Case 2
            Set emailRecipients = emailRecipientsCc
        Case 3
            Set emailRecipients = emailRecipientsBcc
        Case Else
            Debug.Assert eWorksVBA.Assert(False)
        End Select
        
        ' Durch die definierte TO-Empfängerliste iterieren (falls angegeben)
        If Not emailRecipients Is Nothing Then
            For Each emailRecipientIterator In emailRecipients
            
                ' Zugriff auf den Empfänger
                Debug.Assert eWorksVBA.Assert(VarType(emailRecipientIterator) = vbString)
                emailRecipientString = Trim$(CStr(emailRecipientIterator))
                Debug.Assert eWorksVBA.Assert(emailRecipientString <> "")
            
                ' Empfänger zerlegen
                eWorksOutlook.SplitEmailRecipient emailRecipientString, emailRecipientEmailAddress, emailRecipientName
                
                ' E-Mail-Adresse bekannt? (Sonst kein Vergleich möglich.)
                If emailRecipientEmailAddress <> "" Then
                
                    ' Prüfen, ob ein Empfänger mit dieser E-Mail-Adresse schon vorhanden ist -
                    ' entweder in der TO-Liste, oder auch in einer der anderen Listen
                    For Each outlookRecipient In result.Recipients
                    
                        recipientAddress = eWorksOutlook.RecipientGetAddress(outlookRecipient)
                        
                        ' Identischer Empfänger
                        If StrComp(emailRecipientEmailAddress, recipientAddress, VbCompareMethod.vbTextCompare) = 0 Then
                        
                            ' Empfänger gefunden. Falls bisher kein Name bekannt war => Name übernehmen
                            If emailRecipientName = "" And outlookRecipient.name <> "" Then
                                emailRecipientName = outlookRecipient.name
                            End If
                            
                            ' Empfänger löschen
                            outlookRecipient.Delete
                        
                        End If
                    
                    Next
                    
                End If
                
                ' Empfänger hinzufügen
                Set outlookRecipient = result.Recipients.Add(emailRecipientString)
                
                Select Case emailRecipientsIndex
                Case 1
                    outlookRecipient.Type = Outlook.OlMailRecipientType.olTo
                Case 2
                    outlookRecipient.Type = Outlook.OlMailRecipientType.olCC
                Case 3
                    outlookRecipient.Type = Outlook.OlMailRecipientType.olBCC
                Case Else
                    Debug.Assert eWorksVBA.Assert(False)
                End Select
                
            Next
        End If
        
    Next
    
    ' Sicherheitshalber alle Empfänger zum dritten Mal auflösen
    If result.Recipients.Count > 0 Then
        result.Recipients.ResolveAll
    End If
    
    ' E-Mail-Konto zuweisen, falls E-Mail-Konto angegeben
    If emailAccountName <> "" Then
        #If OUTLOOKVERSION And OUTLOOKVERSION <= 2003 Then
            ' Nutzung der SetEmailAccount-Funktionalität in Outlook Version <= 2003
            ' nicht möglich, da Outlook.Account-Objekt noch nicht vorhanden.
            Debug.Assert eWorksVBA.Assert(False)
        #Else
            eWorksOutlook.SetEmailAccount result, emailAccountName
        #End If
    End If
    
    ' E-Mail-Betreff-Prefixe entfernen
    'result.Subject = eWorksEmail.RemoveSubjectPrefixes(result.Subject)
        
    ' E-Mail-Betreff angegeben?
    If emailSubject <> "" Then
    
        emailSubject = replace$(emailSubject, "{SUBJECT}", result.Subject, , , vbTextCompare)
        
        If emailSubjectWas And result.Subject <> "" And Not replyOrForwardEmail Is Nothing Then
        
            ' Klammerausdrücke in altem Betreff entfernen
            result.Subject = Trim$(eWorksString.RemoveBracketTerm(result.Subject))
            
            ' Alten Betreff mit "was: " geprefixt und geklammert anhängen
            emailSubject = emailSubject & " (was: " & result.Subject & ")"
            
        End If
        
        result.Subject = emailSubject
        
    End If
    
    ' Neuen E-Mail-Betreff-Prefix anhängen
    result.Subject = subjectPrefix & result.Subject
    
    ' Sicherstellen, dass die Ticketnummer im Betreff ist, sofern angegeben
    'result.Subject = eWorksEmail.TicketNumberSet(result.Subject, emailTicketNumber)
        
    ' Achtung: es muss bereits zu diesem frühen Zeitpunkt "Display" aufgerufen werden,
    ' damit die Signatur in den E-Mail-Körper eingefügt wird, und außerdem wird auch
    ' die Änderung des E-Mail-Betreffs nicht sichtbar, wenn die E-Mail unsichtbar ist
    If displayEmail Then
    
        result.Display
        
        'VBA.AppActivate "Microsoft Outlook"
        'eWorksExcel.Application.ActivateMicrosoftApp XlMSApplication.xlMicrosoftMail
        'eWorksOutlook.Application.Ac
        
        
        'eWorksOutlook.Application.
        result.GetInspector.Activate
        
        'GetOutlookWindowHandle
        'eWorksOS.WindowActivateByHwnd result.GetInspector.
        
    End If
    
    ' E-Mail-Textkörper-Format zuweisen - falls überhaupt eines definiert ist
    If emailBodyFormat <> Outlook.OlBodyFormat.olFormatUnspecified Then
        result.BodyFormat = emailBodyFormat
    End If
    
    ' Nun E-Mail-Textkörper & E-Mail-Signatur zuweisen:
    result.Body = ""
    
    ' E-Mail-Signatur einfügen / ändern
    Dim emailSignature As String
    If emailSignatureName <> "" Then
    
        ' Achtung, zu diesem Zeitpunkt ist bereits die "Standardsignatur" eingefügt,
        ' sofern eine hinterlegt ist (sehr wahrscheinlich). Diese wird bei automatischer
        ' Signatur-Einfügung leider nicht überschrieben, so dass wir den Body manuell
        ' neu aufbauen müssen
        
        If Not replyOrForwardEmail Is Nothing And Not replyOrForwardClearBodyBefore Then
            result.HTMLBody = replyOrForwardEmail.HTMLBody
        End If
    
        Select Case result.BodyFormat
            Case OlBodyFormat.olFormatPlain:
                emailSignature = eWorksOutlook.SignatureGet(emailSignatureName, SignatureTypeEnum.SignatureTXT)
            Case OlBodyFormat.olFormatHTML:
                emailSignature = eWorksOutlook.SignatureGet(emailSignatureName, SignatureTypeEnum.SignatureHTML)
            Case OlBodyFormat.olFormatRichText:
                emailSignature = eWorksOutlook.SignatureGet(emailSignatureName, SignatureTypeEnum.SignatureRTF)
            Case Else
                Debug.Assert eWorksVBA.Assert(False)
        End Select
        
    End If
    
    ' E-Mail-Textkörper zuweisen, falls angegeben
    If emailBody <> "" Then
        
        Select Case result.BodyFormat
        
            Case OlBodyFormat.olFormatPlain:
            
                If emailSignature <> "" Then
                    emailBody = emailBody & vbNewLine & vbNewLine & emailSignature
                End If
                
                result.Body = emailBody & result.Body
                
            Case OlBodyFormat.olFormatHTML:
            
                ' Signatur anhängen - sicherheitshalber mit etwas Abstand
               result.HTMLBody = emailSignature & "<br/><br/><br/><div></div>" & result.HTMLBody
                
                ' Zugriff auf den Outlook-HTML-Editor a.k.a. MS-Word (geht besser als HTML-Manipulation)
                Set wordDocument = result.GetInspector.wordEditor
                
                ' Einzufügenden Body-Text 1-absätzig machen
                emailBody = replace$(emailBody, vbCrLf, Chr$(11))
                emailBody = replace$(emailBody, vbCr, Chr$(11))
                emailBody = replace$(emailBody, vbLf, Chr$(11))
                
                ' Einfügeposition ermitteln
                Set wordParagraph = wordDocument.Paragraphs(1)
                
                ' Body-Text einfügen
                wordParagraph.Range.InsertBefore emailBody
                
                ' Text lokal und per Formatvorlage/CSS-Klasse umformatieren
                On Error Resume Next
                wordDocument.Styles(wordDocument.Paragraphs(1).Style).Font.name = "Calibri"
                wordDocument.Styles(wordDocument.Paragraphs(1).Style).Font.Size = 11
                wordDocument.Paragraphs(1).Range.Font.name = "Calibri"
                On Error GoTo Catch
                
                ' P.S. einfügen - ebenfalls mit etwas Abstand
                If emailBodyPS <> "" Then
                    emailBodyPS = "<br><br>" & eWorksString.ToHtml(emailBodyPS)
                    result.HTMLBody = eWorksOutlook.EmailInsertPsText(result.HTMLBody, emailBodyPS, "-- ")
                End If
                
                ' "Auto-formatieren" (insb. wg. der Hyperlinks)
                wordDocument.Application.Options.AutoFormatReplaceHyperlinks = True
                wordParagraph.Range.AutoFormat
            
            Case OlBodyFormat.olFormatRichText:
            
                result.RTFBody = emailBody & result.RTFBody
            
            Case Else
            
                Debug.Assert eWorksVBA.Assert(False)
                
        End Select
        
    End If
    
Finally:

    On Error GoTo 0
    
    Set EmailCreate = result
    Exit Function
    
Catch:
    
    ' Damit kein Mail-Objekt im inkonsistenten Zustand geliefert wird, hier auf Nothing setzen.
    Set result = Nothing
    eWorksVBA.HandleError Err, MODULE_NAME, "EmailCreate", True
    GoTo Finally
    
End Function

' ==============================================================================
' Fügt einen P.S.-Text in einen E-Mail-Text im HTML-Format ein.
' ==============================================================================
Public Function EmailInsertPsText( _
    ByVal emailBody As String, _
    ByVal emailBodyPsText As String, _
    ByVal signaturePattern As String) As String

    On Error GoTo Catch

    Dim result As String
    Dim signaturePatternStartPos As Long
    Dim signaturePatternLineStartPos As Long
    Dim signaturePatternLineStartPos1 As Long
    Dim signaturePatternLineStartPos2 As Long
    Dim signaturePatternLineStartPos3 As Long
    
    ' Parameter aufbereiten & prüfen
    Debug.Assert eWorksVBA.Assert(signaturePattern <> "")
    
    ' Rückgabe initialisieren
    result = emailBody

    ' Signatur-Pattern suchen
    signaturePatternStartPos = InStr(1, emailBody, signaturePattern, VbCompareMethod.vbTextCompare)
    
    ' Signatur-Pattern gefunden?
    If signaturePatternStartPos > 0 Then
    
        ' Zeilenanfang suchen
        signaturePatternLineStartPos1 = InStrRev(emailBody, "<br", signaturePatternStartPos, VbCompareMethod.vbTextCompare)
        signaturePatternLineStartPos2 = InStrRev(emailBody, "<div", signaturePatternStartPos, VbCompareMethod.vbTextCompare)
        signaturePatternLineStartPos3 = InStrRev(emailBody, "<p", signaturePatternStartPos, VbCompareMethod.vbTextCompare)
        
        ' Maximum ermitteln
        signaturePatternLineStartPos = signaturePatternLineStartPos1
        If signaturePatternLineStartPos2 > signaturePatternLineStartPos Then
            signaturePatternLineStartPos = signaturePatternLineStartPos2
        End If
        If signaturePatternLineStartPos3 > signaturePatternLineStartPos Then
            signaturePatternLineStartPos = signaturePatternLineStartPos3
        End If
        
        ' Zeilenanfang nicht gefunden?
        If signaturePatternLineStartPos < 1 Then
            signaturePatternLineStartPos = 1
        End If
        
    Else
    
        signaturePatternLineStartPos = 1
        
    End If
    
    ' Nun P.S.-Text einfügen
    Debug.Assert eWorksVBA.Assert(signaturePatternLineStartPos >= 1)
    result = _
        Left$(result, signaturePatternLineStartPos - 1) & _
        emailBodyPsText & _
        Right$(result, Len(result) - signaturePatternLineStartPos + 1)

Finally:

    On Error GoTo 0

    EmailInsertPsText = result
    Exit Function

Catch:

    eWorksVBA.HandleError Err, MODULE_NAME, "EmailInsertPsText", True
    GoTo Finally

End Function



' ==============================================================================
' Bereitet eine neue E-Mail vor und erzeugt diese mit den übergebenen Daten.
'
' Um individuellen Inhalt zu übergeben können Templates mit Platzhaltern
' übergeben werden, deren Platzhalter mit den Daten aus dem übergebenen Datensatz
' ersetzt werden.
'
' Es können die Namen von Dateien Semikolo-separiert übergeben werden, welche
' als Anhänge an die E-Mail angefügt werden.
' ==============================================================================
Public Function EmailSend( _
    ByVal mailData As eWorksCollection, _
    Optional ByVal showMessages As Boolean = False, _
    Optional ByVal emailSubjectTemplate As String = "", _
    Optional ByVal emailBodyTemplate As String = "", _
    Optional ByVal emailToTemplate As String = "", _
    Optional ByVal emailCcTemplate As String = "", _
    Optional ByVal emailBccTemplate As String = "", _
    Optional ByVal emailSignatureName As String = "", _
    Optional ByVal emailBodyFormat As Long = 0, _
    Optional ByVal displayEmail As Boolean = True, _
    Optional ByVal emailAttachments As String = "") As Outlook.MailItem

    On Error GoTo Catch
    
    Dim outlookMailItem As Outlook.MailItem
    Dim selectedData As eWorksCollection
    Dim emailSubject As String
    Dim emailBody As String
    Dim emailTo As String
    Dim emailCc As String
    Dim emailBcc As String
    Dim doSkip As Boolean
    Dim attachmentItems As eWorksCollection
    Dim attachmentItem As Variant
    
    ' Platzhalter ersetzen
    emailSubject = eWorksString.PlaceholdersReplace(emailSubjectTemplate, mailData, , "")
    emailBody = eWorksString.PlaceholdersReplace(emailBodyTemplate, mailData, , "")
    emailTo = eWorksString.PlaceholdersReplace(emailToTemplate, mailData, , "")
    emailCc = eWorksString.PlaceholdersReplace(emailCcTemplate, mailData, , "")
    emailBcc = eWorksString.PlaceholdersReplace(emailBccTemplate, mailData, , "")
    
    ' Ein E-Mail-Objekt für diesen Empfänger erstellen
    Set outlookMailItem = eWorksOutlook.EmailCreate(showMessages, displayEmail, emailSubject, True, emailBody, _
        emailBodyFormat, emailTo, emailCc, emailBcc, emailSignatureName)
    Debug.Assert eWorksVBA.Assert(Not outlookMailItem Is Nothing)
    
    ' Wenn Anhänge übergeben wurden ...
    If Trim$(emailAttachments) <> "" Then
    
        ' ... splitte diese auf.
        Set attachmentItems = eWorksString.SplitString(emailAttachments, ";")
        Debug.Assert eWorksVBA.Assert(Not attachmentItems Is Nothing)
    
        ' Iteriere über die übergebenen Anhänge, ...
        For Each attachmentItem In attachmentItems
        
            ' prüfe, ob sie existieren ...
            If eWorksIO.FileExists(attachmentItem) Then
            
                ' ... und hänge sie an die E-Mail an.
                outlookMailItem.Attachments.Add "" & CStr(attachmentItem)
            
            End If
        
        Next
    
    End If
    
Finally:

    On Error GoTo 0
    
    Set EmailSend = outlookMailItem
    
    Exit Function
    
Catch:

    eWorksVBA.HandleError Err, MODULE_NAME, "EmailSend", True
    GoTo Finally

End Function

' ==============================================================================
' Ermittelt den Inhalt der Signatur mit dem übergebenen Namen in dem übergebenen
' Format. Für die Typen "TXT" und "HTML" wird ein String zurückgegeben. Für den
' Typ "RTF" eine Byte-Array.
' ==============================================================================
Public Function SignatureGet( _
    ByVal signatureName As String, _
    ByVal signatureType As SignatureTypeEnum) As Variant
    
    On Error GoTo Catch
    
    Dim result As Variant
    Dim signatureFileName As String
    Dim signatureFileNameExtension As String
    Dim basePath As String
    
    ' Ermittle die Dateiendung der Datei, in der die Signatur gespeichert ist
    ' in Abhängigkeit des Signaturtyps.
    Select Case signatureType
    Case SignatureTypeEnum.SignatureTXT
        signatureFileNameExtension = "txt"
    Case SignatureTypeEnum.SignatureHTML
        signatureFileNameExtension = "htm"
    Case SignatureTypeEnum.SignatureRTF
        signatureFileNameExtension = "rtf"
    Case Else
        signatureFileNameExtension = "txt"
    End Select
    
    ' Konstruiere den vollständigen Dateinamen.
    signatureFileName = eWorksString.Combine(".", signatureName, signatureFileNameExtension)
    signatureFileName = eWorksIO.PathCombine(VBA.Environ("appdata"), "Microsoft\Signatures", signatureFileName)
    
    ' Wenn die Datei für die Signatur existiert ...
    If eWorksIO.FileExists(signatureFileName) Then
        
        ' ... lies deren Inhalt ein.
        Select Case signatureType
        Case SignatureTypeEnum.SignatureTXT
            result = eWorksOutlook.SignatureReadPlain(signatureFileName)
        Case SignatureTypeEnum.SignatureHTML
        
            result = eWorksOutlook.SignatureReadPlain(signatureFileName)
            
            ' Schneide alles außer dem Body raus
            result = eWorksHTML.HtmlBodyExtract(result, True)
            'result = "<html><head><xml><o:OfficeDocumentSettings><o:AllowPNG/></o:OfficeDocumentSettings></xml></head><body>" & result & "</body></html>"
            
            ' <img>-Tags aufbereiten
            basePath = eWorksIO.PathCombine(VBA.Environ("appdata"), "Microsoft\Signatures\")
            result = eWorksOutlook.OutlookImageTagsProcess(result, basePath)
                
            ' Absatz-Formatvorlagen und -Inline-Styles normalisieren
            result = replace(result, "class=MsoNormal", "class=eWorksNormal style=""font-size:11.0pt; font-family:'Calibri','sans-serif'; margin:0; padding:0;""")
            result = replace(result, "class=WordSection1", "class=eWorksNormal style=""font-size:11.0pt; font-family:'Calibri','sans-serif'; margin:0; padding:0;""")
            
        Case SignatureTypeEnum.SignatureRTF
            result = eWorksOutlook.SignatureReadRTF(signatureFileName)
        Case Else
            result = eWorksOutlook.SignatureReadPlain(signatureFileName)
        End Select
        
    End If
    
Finally:

    On Error GoTo 0
    
    SignatureGet = result
    
    Exit Function
    
Catch:

…