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.


Thanks

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.

Code:

---

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
    RemoveLinks Item
    Item.Save
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.

Code:

---

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
lbl_Exit:
    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

Code:

---

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
lbl_Exit:
    Exit Sub
End Sub

---