Hi njcloud,
Try the following:
Code:
Sub ConvertHyperlinks()
Dim RngFld As Range, RngTmp As Range, oFld As Field, StrTmp As String, HLink As Hyperlink
' Turn Off Screen Updating
Application.ScreenUpdating = False
ActiveDocument.ActiveWindow.View.ShowFieldCodes = True
Set RngFld = ActiveDocument.Range
With RngFld
'Convert HREF codes to {HYPERLINK \1}«\2» format
With .Find
.Text = "\<[Aa] href=([!\>]{1,})\>([!\<]{1,})\</a\>"
.ClearFormatting
.Replacement.ClearFormatting
.Replacement.Text = "{HYPERLINK \1}«\2»"
.Forward = True
.MatchWildcards = True
.Execute Replace:=wdReplaceAll
End With
'Validate content
If Len(Replace(.Text, "{", vbNullString)) <> Len(Replace(.Text, "}", vbNullString)) Then
MsgBox "Unmatched field brace pairs in the document.", vbCritical + vbOKOnly, "Error!"
Exit Sub
End If
If Len(Replace(.Text, "«", vbNullString)) <> Len(Replace(.Text, "»", vbNullString)) Then
MsgBox "Unmatched 'Text to display' tags in the document.", vbCritical + vbOKOnly, "Error!"
Exit Sub
End If
'Convert Hyperlink fields
Do While InStr(1, .Text, "{") > 0
Set RngTmp = ActiveDocument.Range(Start:=.Start + _
InStr(.Text, "{") - 1, End:=.Start + InStr(.Text, "}"))
With RngTmp
Do While Len(Replace(.Text, "{", vbNullString)) <> _
Len(Replace(.Text, "}", vbNullString))
.End = .End + 1
If .Characters.Last.Text <> "}" Then .MoveEndUntil cset:="}", _
Count:=Len(ActiveDocument.Range(.End, RngFld.End))
Loop
.Characters.First = vbNullString
.Characters.Last = vbNullString
StrTmp = .Text
Set oFld = ActiveDocument.Fields.Add(Range:=RngTmp, _
Type:=wdFieldEmpty, Text:="", PreserveFormatting:=False)
oFld.Code.Text = StrTmp
End With
Loop
ActiveDocument.ActiveWindow.View.ShowFieldCodes = False
'update the field display
.Fields.Update
'Update the hyperlink 'Text To Display' values
For Each HLink In .Hyperlinks
Set RngTmp = HLink.Range
With RngTmp
If .Characters.Last.Next = "«" Then
.MoveEndUntil cset:="»"
.MoveStartUntil cset:="«"
.Characters.First.Delete
.Characters.Last.Next.Delete
HLink.TextToDisplay = Trim(.Text)
.Delete
End If
End With
Next
End With
Set RngTmp = Nothing: Set RngFld = Nothing: Set oFld = Nothing
' Restore Screen Updating
Application.ScreenUpdating = True
End Sub
Note: The code does all the Find/Replace work and conversion in one go. As part of the Find/Replace work, the '{ }' pairs are created for the field code, along with some temporary '« »' pairs for the 'Text To Display'. If you use any of these characters elsewhere in the document, some different (unused) characters will be needed.