MS Outlook Как изменить строку темы (Strip RE:/FW и добавить префикс)

Question

Я хочу изменить строку темы для входящих и исходящих писем с помощью автоматического макроса.

Вот что я искал:

1. Макрос для автоматического удаления RE:, Re:, FW:, Fw: из входящих писем. Я попробовал приведенный ниже макрос, но он не работает.
2. Добавьте префикс к новому или ответному письму на основе адреса электронной почты получателя в строке «Кому».

Например, если адрес электронной почты имеет адрес *@root.com, добавьте префикс Root Company -

Macro:

Const CLASS_NAME = "SendAndReceive"

Private WithEvents olkApp As Outlook.Application
Private bolSend As Boolean, bolReceive As Boolean

Private Sub Class_Initialize()
    bolSend = True
    bolReceive = True
    Set olkApp = Outlook.Application
End Sub

Private Sub Class_Terminate()
    Set olkApp = Nothing
End Sub

Private Sub olkApp_ItemSend(ByVal Item As Object, Cancel As Boolean)
    If (Left(Item.Subject, 4) = "FW: ") Or (Left(Item.Subject, 4) = "RE:") Then
        Item.Subject = Mid(Item.Subject, 5)
        Item.Save
    Else
        If Left(Item.Subject, 5) = "Fwd: " Then
            Item.Subject = Mid(Item.Subject, 6)
            Item.Save
        End If
    End If
End Sub

Private Sub olkApp_NewMailEx(ByVal EntryIDCollection As String)
    Dim arrEID As Variant, varEID As Variant, olkItm As Object
    arrEID = Split(EntryIDCollection, ",")
    For Each varEID In arrEID
        Set olkItm = Outlook.Session.GetItemFromID(varEID)
        If olkItm.Class = olMail Then
            Select Case Left(olkItm.Subject, 4)
                Case "FW: ", "RE: "
                    olkItm.Subject = Mid(olkItm.Subject, 5)
                    olkItm.Save
            End Select
        End If
    Next
    Set olkItm = Nothing
End Sub

Public Sub ToggleSend()
    bolSend = Not bolSend
    MsgBox "The process of removing RE: and FW: on sent messages has been turned " & IIf(bolSend, "'On'", "'Off'"), vbInformation + vbOKOnly, CLASS_NAME
End Sub

Public Sub ToggleReceive()
    bolReceive = Not bolReceive
    MsgBox "The process of removing 'RE:', 'FW:', and 'Fwd:'  on received messages has been turned " & IIf(bolReceive, "'On'", "'Off'"), vbInformation + vbOKOnly, CLASS_NAME
End Sub

Answer 1

Скорее всего, вы должны были создать модуль класса.

Проще использовать встроенный модуль класса ThisOutlookSession. Он уже настроен на использование "приложения".

Const CLASS_NAME = "SendAndReceive"

Private bolSend As Boolean, bolReceive As Boolean

Private Sub application_startup()
    bolSend = True
    bolReceive = True
End Sub

Private Sub application_ItemSend(ByVal Item As Object, Cancel As Boolean)
    ' Typo fixed here
    If (Left(Item.Subject, 4) = "FW: ") Or (Left(Item.Subject, 4) = "RE: ") Then
        Item.Subject = Mid(Item.Subject, 5)
        Item.Save
    Else
        If Left(Item.Subject, 5) = "Fwd: " Then
            Item.Subject = Mid(Item.Subject, 6)
            Item.Save
        End If
    End If
End Sub

Private Sub application_NewMailEx(ByVal EntryIDCollection As String)
    Dim arrEID As Variant, varEID As Variant, olkItm As Object
    arrEID = Split(EntryIDCollection, ",")
    For Each varEID In arrEID
        Set olkItm = Outlook.Session.GetItemFromID(varEID)
        If olkItm.Class = olMail Then
            Select Case Left(olkItm.Subject, 4)
                Case "FW: ", "RE: "
                Debug.Print olkItm.Subject
                    olkItm.Subject = Mid(olkItm.Subject, 5)
                    olkItm.Save
            End Select
        End If
    Next
    Set olkItm = Nothing
End Sub

Public Sub ToggleSend()
    bolSend = Not bolSend
    MsgBox "The process of removing RE: and FW: on sent messages has been turned " & IIf(bolSend, "'On'", "'Off'"), vbInformation + vbOKOnly, CLASS_NAME
End Sub

Public Sub ToggleReceive()
    bolReceive = Not bolReceive
    MsgBox "The process of removing 'RE:', 'FW:', and 'Fwd:'  on received messages has been turned " & IIf(bolReceive, "'On'", "'Off'"), vbInformation + vbOKOnly, CLASS_NAME
End Sub