Nummerierung in E-Mailbetreff statt AW

' 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 reformat subject for reply  
Private Function ReformatResponseSubject(ByVal mail As MailItem) As Variant
    Dim strNewSubject As String, regex As Object, cnt As Integer, matches As Object, match As Object
    Set regex = CreateObject("vbscript.regexp")  
    regex.Global = True: regex.IgnoreCase = True: regex.MultiLine = False
    ' Pattern for reply strings  
    regex.Pattern = "(AW|RE|RE-(\d+)):"  
    ' execute regex  
    Set matches = regex.Execute(mail.Subject)
    ' if reply found  
    If matches.Count > 0 Then
        ' default count to number of reply strings found + 1  
        cnt = matches.Count + 1
        ' find RE-[::digit::] pattern in that case use digits as counter + 1  
        For Each match In matches
            If Not IsEmpty(matches(0).submatches(1)) Then
                cnt = CInt(match.submatches(1)) + 1
                Exit For
            End If
        Next
        ' replace reply strings with empty string and add new prefix  
        strNewSubject = "RE-" & cnt & ":" & regex.Replace(mail.Subject, "")  
        ' return new subject  
        ReformatResponseSubject = strNewSubject
    Else ' no reply found  
        ReformatResponseSubject = vbNull
    End If
    Set regex = Nothing
    Set matches = Nothing
End Function

' Response is Inline-Response  
Private Sub actExplorer_InlineResponse(ByVal Item As Object)
    Dim result As Variant
    result = ReformatResponseSubject(actMessage)
    If result <> vbNull Then
        Item.Subject = result
    End If
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)
    On Error Resume Next
    Dim res As MailItem, strSalutation As String, actInspector As Inspector, result As Variant
    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
            result = ReformatResponseSubject(actMessage)
            If result <> vbNull Then
                res.Subject = result
            End If
            ' Cancel original response  
            Cancel = True
            ' show new response object  
            .Display
        End With
    End If
End Sub