Removing addresses from forwards and replies

[MikeHH]

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

[gmayor]

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
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.


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

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