Results 1 to 2 of 2

Thread: Removing addresses from forwards and replies

  1. #1
    VBAX Newbie
    Jun 2020

    Removing addresses from forwards and replies

    So, my colleague is a bit neurotic and insists that there are no email addresses left in the body of anything we forward or reply to. So I am trying to automate the process where we have to read down the body of all emails and remove all the mailto links and email addresses.
    I am comfortable with VBA code in Excel and Word. But don't really know my way around Outlook. I am hoping to find a way that all addresses can be removed without us having to remember to do it every time.


  2. #2
    Programming in Outlook is not that difficult though it is poorly documented. Add the following to the ThisOutlookSession module to process each message as it is sent.

    Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
        RemoveLinks Item
    End Sub
    In an ordinary module add the following. Here wdDoc is the message body which can be processed pretty much as you can process a Word document using VBA, and it is searched for e-mail address links.
    The only real proviso is that you cannot use Word specific commands, which should be replaced with their numeric equivalents as when using late binding in Excel to access Word. You may wish to modify the code to make it do exactly what is required.

    Sub RemoveLinks(oItem As MailItem)
    Dim olInsp As Inspector
    Dim wdDoc As Object
    Dim oRng As Object
    Dim oLink As Object
    Dim i As Long
        If TypeName(oItem) = "MailItem" Then
            With oItem
                Set olInsp = .GetInspector
                Set wdDoc = olInsp.WordEditor
                .Display    'required
                Set oRng = wdDoc.Range
                'do stuff with orng (the body of the message) e.g.
                For i = oRng.Hyperlinks.Count To 1 Step -1
                    Set oLink = oRng.Hyperlinks(i)
                    If InStr(1, oLink.Address, "mailto") > 0 Then
                        oLink.Range.Text = ""
                    End If
                Next i
            End With
        End If
        Set olInsp = Nothing
        Set wdDoc = Nothing
        Set oRng = Nothing
        Exit Sub
    End Sub
    You can use the following macro to test the above code with a selected message
    Sub TestMacr0()
    Dim olMsg As MailItem
        On Error Resume Next
        Select Case Outlook.Application.ActiveWindow.Class
            Case olInspector
                Set olMsg = ActiveInspector.currentItem
            Case olExplorer
                Set olMsg = Application.ActiveExplorer.Selection.Item(1)
        End Select
        RemoveLinks olMsg
        Exit Sub
    End Sub
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts