MS Outlook Como alterar a linha de assunto (Faixa RE: / FW e Adicionar prefixo)

Question

Eu quero alterar a linha de assunto para e-mails recebidos e enviados por meio da macro automática.

Aqui está o que eu tenho procurado:

1. Uma macro para tira automática RE:, Re :, FW :, Fw: de emails recebidos. Eu tentei a macro abaixo, mas não funciona.
2. Adicione o prefixo a novo ou responda por e-mail com base no endereço de e-mail do destinatário na linha Para:.

Por exemplo, se o endereço de e-mail tiver *@root.com, adicione o prefixo Empresa raiz -

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

Provavelmente você deveria criar um módulo de classe.

É mais simples usar o módulo interno da classe, ThisOutlookSession. Já está configurado para usar "aplicativo".

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