Automatische Anrede mit Name in Outlook beim Antworten auf Mails

' Exlorers object in current application  
Dim WithEvents allExplorers As Explorers
' collection which will hold all explorers  
Dim ExplorerCollection As New Collection

' when new explorer is created  
Private Sub allExplorers_NewExplorer(ByVal Explorer As Explorer)
    On Error Resume Next
    AddExplorerEvents Explorer
End Sub
' on outlook startup  
Private Sub Application_Startup()
    On Error Resume Next
    AddExplorerEvents ActiveExplorer
    Set allExplorers = Application.Explorers
End Sub

Private Sub AddExplorerEvents(ByVal exp As Explorer)
    ' create event class  
    Dim c As New newExplorerClass
    ' and add Explorer Object to its public variable  
    Set c.actExplorer = exp
    ' add explorer to collection  
    ExplorerCollection.Add c
End Sub

' Explorer Object to work on  
Public WithEvents actExplorer As Explorer
' current Message object working on  
Dim WithEvents actMessage As MailItem

' Function to get personal salutation  
Private Function GetPersonalSalutationForMailSender(ByVal mail As MailItem) As String
    Dim strSalutation As String, strLastName As String, strCompanyName As String, strTitle As String, folderContacts As Folder
    
    ' search contact from sender address entry  
    ' if the sender is an Exchange User...  
    If mail.Sender.AddressEntryUserType = olExchangeUserAddressEntry Then
        Dim exUser As ExchangeUser
        ' get exange user obect  
        Set exUser = mail.Sender.GetExchangeUser
        If Not exUser Is Nothing Then
            ' get properties  
            strLastName = exUser.LastName
            strCompanyName = exUser.CompanyName
            ' Get title from LDAP "title" attribute (Deutsch: "Position" , sorry there is no real DisplayName Prefix attribute in AD)  
            strTitle = exUser.PropertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x3A17001E")  
        End If
    Else    ' other entry  
        Dim c As ContactItem
        ' try to get contact from local address book  
        Set c = mail.Sender.GetContact
        ' if entry found use properties  
        If Not c Is Nothing Then
            strLastName = c.LastName
            strCompanyName = c.CompanyName
            strTitle = c.Title
        End If
    End If
    
    ' when Lastname ist not empty  
    If strLastName <> "" Then  
        ' different salutations for different titles  
        Select Case strTitle
            Case "Herr"  
                strSalutation = "Sehr geehrter Herr " & strLastName & ","  
            Case "Doktor"  
                strSalutation = "Sehr geehrter Doktor " & strLastName & ","  
            Case "Professor"  
                strSalutation = "Sehr geehrter Professor " & strLastName & ","  
            Case "Firma"  
                strSalutation = "Sehr geehrte Firma " & strCompanyName & ","  
            Case "Frau"  
                strSalutation = "Sehr geehrte Frau " & strLastName & ","  
            Case "Familie"  
                strSalutation = "Sehr geehrte Familie " & strLastName & ","  
            Case Else
                strSalutation = "Sehr geehrte Damen und Herren,"  
        End Select
    ' if Lastname is empty check company  
    ElseIf strCompanyName <> "" Then  
        strSalutation = "Sehr geehrte Firma " & strCompanyName & ","  
    Else ' generic string  
        strSalutation = "Sehr geehrte Damen und Herren,"  
    End If
    ' append additional newline to salutation  
    strSalutation = strSalutation & vbNewLine
    ' set return of function  
    GetPersonalSalutationForMailSender = strSalutation
End Function

' Response is Inline-Response  
Private Sub actExplorer_InlineResponse(ByVal Item As Object)
    Dim strSalutation As String

    ' get personal salutation and set body of inline response  
    With Item
        strSalutation = GetPersonalSalutationForMailSender(actMessage)
        If .BodyFormat = olFormatHTML Then
            .HTMLBody = RewriteHTMLBody(.HTMLBody, strSalutation)
        Else
            .body = strSalutation & vbNewLine & .body
        End If
    End With
End Sub
' keep track of current item  
Private Sub actExplorer_SelectionChange()
    If Not actExplorer Is Nothing Then
        With actExplorer
            If .Selection.Count > 0 Then
                If .Selection(1).Class = olMail Then
                    Set actMessage = .Selection(1)
                End If
            End If
        End With
    End If
End Sub


' if item is replied to  
Private Sub actMessage_Reply(ByVal Response As Object, Cancel As Boolean)
    Dim res As MailItem, strSalutation As String, actInspector As Inspector
    Set actInspector = ActiveInspector
    ' check if there is an active Inspector (if not it's an inline response)  
    If Not actInspector Is Nothing Then
        ' if the item in the activeinspector is not the message replied to it's an inlineresponse, so exit event  
        If actInspector.CurrentItem <> actMessage Then Exit Sub
        ' create response  
        Set res = actMessage.Reply
        With res
            ' get personal salutation from Sender-Contact in address book  
            strSalutation = GetPersonalSalutationForMailSender(actMessage)
            ' determine body format and set body  
            If .BodyFormat = olFormatHTML Then
                .HTMLBody = RewriteHTMLBody(.HTMLBody, strSalutation)
            Else
                .body = strSalutation & vbNewLine & .body
            End If
            ' Cancel original response  
            Cancel = True
            ' show new response object  
            .Display
        End With
    End If
End Sub

' prepend HTML content to body  
Function RewriteHTMLBody(body As String, prepend As String) As String
    Set regex = CreateObject("vbscript.regexp")  
    regex.IgnoreCase = True
    regex.Pattern = "(<body[^>]*>)([\s\S]+)"  
    RewriteHTMLBody = regex.Replace(body, ("$1" & prepend & "<br/>$2"))  
    Set regex = Nothing
End Function

            .Body = "Sehr geehrte Damen und Herren," & vbNewLine & .Body  

' Explorer Object to work on  
Public WithEvents actExplorer As Explorer
' current Message object working on  
Dim WithEvents actMessage As MailItem
' inspector inspection  
Dim WithEvents myInspectors As Inspectors


' Function to get personal salutation  
Private Function GetPersonalSalutationForMailSender(ByVal mail As MailItem) As String
    Dim strSalutation As String, strLastName As String, strCompanyName As String, strTitle As String, folderContacts As Folder
    
    ' search contact from sender address entry  
    ' if the sender is an Exchange User...  
    If mail.Sender.AddressEntryUserType = olExchangeUserAddressEntry Then
        Dim exUser As ExchangeUser
        ' get exange user obect  
        Set exUser = mail.Sender.GetExchangeUser
        If Not exUser Is Nothing Then
            ' get properties  
            strLastName = exUser.LastName
            strCompanyName = exUser.CompanyName
            ' Get title from LDAP "title" attribute (Deutsch: "Position" , sorry there is no real DisplayName Prefix attribute in AD)  
            strTitle = exUser.PropertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x3A17001E")  
        End If
    Else    ' other entry  
        Dim c As ContactItem
        ' try to get contact from local address book  
        Set c = mail.Sender.GetContact
        ' if entry found use properties  
        If Not c Is Nothing Then
            strLastName = c.LastName
            strCompanyName = c.CompanyName
            strTitle = c.Title
        End If
    End If
    
    ' when Lastname ist not empty  
    If strLastName <> "" Then  
        ' different salutations for different titles  
        Select Case strTitle
            Case "Herr"  
                strSalutation = "Sehr geehrter Herr " & strLastName & ","  
            Case "Doktor"  
                strSalutation = "Sehr geehrter Doktor " & strLastName & ","  
            Case "Professor"  
                strSalutation = "Sehr geehrter Professor " & strLastName & ","  
            Case "Firma"  
                strSalutation = "Sehr geehrte Firma " & strCompanyName & ","  
            Case "Frau"  
                strSalutation = "Sehr geehrte Frau " & strLastName & ","  
            Case "Familie"  
                strSalutation = "Sehr geehrte Familie " & strLastName & ","  
            Case Else
                strSalutation = "Sehr geehrte Damen und Herren,"  
        End Select
    ' if Lastname is empty check company  
    ElseIf strCompanyName <> "" Then  
        strSalutation = "Sehr geehrte Firma " & strCompanyName & ","  
    Else ' generic string  
        strSalutation = "Sehr geehrte Damen und Herren,"  
    End If
    ' append additional newline to salutation  
    strSalutation = strSalutation & vbNewLine
    ' set return of function  
    GetPersonalSalutationForMailSender = strSalutation
End Function

Private Sub actExplorer_Activate()
    With actExplorer
        If .Selection.Count > 0 Then
            If .Selection(1).Class = olMail Then
                Set actMessage = .Selection(1)
            End If
        End If
    End With
End Sub

' Response is Inline-Response  
Private Sub actExplorer_InlineResponse(ByVal Item As Object)
    Dim strSalutation As String
    'get personal salutation and set body of inline response  
    With Item
        strSalutation = GetPersonalSalutationForMailSender(actMessage)
        If .BodyFormat = olFormatHTML Then
            .HTMLBody = RewriteHTMLBody(.HTMLBody, strSalutation)
        Else
            .body = strSalutation & vbNewLine & .body
        End If
    End With
End Sub
' keep track of current item  
Private Sub actExplorer_SelectionChange()
    If Not actExplorer Is Nothing Then
        With actExplorer
            If .Selection.Count > 0 Then
                If .Selection(1).Class = olMail Then
                    Set actMessage = .Selection(1)
                End If
            End If
        End With
    End If
End Sub

' if item is replied to  
Private Sub actMessage_Reply(ByVal Response As Object, Cancel As Boolean)
    Dim res As MailItem, strSalutation As String, actInspector As Inspector
    Set actInspector = ActiveInspector
    ' check if there is an active Inspector (if not it's an inline response)  
    If actInspector Is Nothing Then Exit Sub
    ' if the item in the activeinspector is not the message replied to it's an inlineresponse, so exit event  
    If actInspector.CurrentItem <> actMessage Then Exit Sub
    ' Cancel original response  
    Cancel = True
    ' create response  
    Set res = actMessage.Reply

    With res
        'CreateObject("Scripting.FilesystemObject").OpenTextFile("C:\Users\Uwe\Desktop\htmlbody.txt", 2, True).Write .HTMLBody  
        ' get personal salutation from Sender-Contact in address book  
        strSalutation = GetPersonalSalutationForMailSender(actMessage)
        ' determine body format and set body  
        If .BodyFormat = olFormatHTML Then
            .HTMLBody = RewriteHTMLBody(.HTMLBody, strSalutation)
        Else
            .body = strSalutation & vbNewLine & .body
        End If
        ' show new response object  
        .Display
    End With
End Sub

' prepend HTML content to body  
Function RewriteHTMLBody(body As String, prepend As String) As String
    Set regex = CreateObject("vbscript.regexp")  
    regex.IgnoreCase = True
    regex.Pattern = "(<body[^>]*>)([\s\S]+)"  
    RewriteHTMLBody = regex.Replace(body, ("$1" & prepend & "<br/>$2"))  
    Set regex = Nothing
End Function

' class initializer  
Private Sub Class_Initialize()
    ' set inspectors object  
    Set myInspectors = Application.Inspectors
End Sub

' event is run on creation of new inspectors  
Private Sub myInspectors_NewInspector(ByVal Inspector As Inspector)
    With Inspector.CurrentItem
        ' if it's a new item insert a default salutation in the body  
        If .EntryID = "" And .Subject = "" Then  
            .body = "Sehr geehrte Damen und Herren," & vbNewLine & .body  
        End If
    End With
End Sub

Private Sub actMessage_Reply(ByVal Response As Object, Cancel As Boolean)
    On Error Resume Next
    Dim res As MailItem, strSalutation As String, actInspector As Inspector
    Set actInspector = ActiveInspector
    ' check if there is an active Inspector (if not it's an inline response)  
    If Not actInspector Is Nothing Then

    End If
End Sub

Private Sub myInspectors_NewInspector(ByVal Inspector As Inspector)