Removing HTTP from URLs

Graham is a copyeditor and one of the (quite usual) tasks he faces is to remove http:// from URLs that start http://www. Graham finds this task easy if the URL is just text. However, if it is a hyperlink he has to display the Edit Hyperlink dialog box, select http:// in the Text to Display field, delete it, and close the dialog box.

Fortunately, you don't have to always display the Edit Hyperlink dialog box to make your changes. Even if a hyperlink is active, you can find and replace information in what is displayed. For instance, doing a search for http://www and replacing it with www will work just fine, even for active hyperlinks. Word changes just the text that is displayed and not the underlying hyperlink itself.

If you have many, many hyperlinks to edit and this truncation of URLs is a common task, you may want to use a macro to handle this. You can develop a short macro that will step through each hyperlink in the document and remove the http:// portion. The following is an example:

Sub FixHyperlinks1()
    Dim hyp As Hyperlink
    Dim sLink As String

    For Each hyp In ActiveDocument.Hyperlinks
        sLink = hyp.Address
        sLink = replace(strLink, "http://www", "www")
        hyp.Address = sLink
    Next hyp
End Sub

This approach is probably not as comprehensive as you want, however. It only affects active hyperlinks; it doesn't affect plain-text URLs in your document. If you want to use a more comprehensive approach, you need something that will get rid of all the hyperlinks (you probably don't need them in the document in the first place) and then get rid of the http:// portion. Here's one that will do just that:

Sub FixHyperlinks2()
'Remove hyperlinks
    With ActiveDocument
        While .Hyperlinks.Count > 0
            .Hyperlinks(1).Delete
        Wend
    End With

'Remove http://
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "http://www"
        .Replacement.Text = "www"
        .Forward = True
        .Wrap = wdFindContinue
     End With
    Selection.Find.Execute Replace:=wdReplaceAll
End Sub