Sub UpdateTOC()
' Update TOC and hyperlinks Macro
Application.ScreenUpdating = False
Dim hyp As Hyperlink
Dim toc As TableOfContents
Dim k As Long
Dim bkmk As String
Dim sCode As String
Dim fld As Field
Dim aRange As Range
If ActiveDocument.TablesOfContents.Count = 0 Then
MsgBox "There are no Tables of Contents in document"
Exit Sub
End If
If ActiveDocument.TablesOfContents.Count = 1 Then _
ActiveDocument.TablesOfContents(1).Update
Set toc = ActiveDocument.TablesOfContents(1)
For Each fld In toc.Range.Fields
sCode = fld.Code.Text
If InStr(sCode, "HYPERLINK") > 0 Then bkmk = Mid(sCode, InStr(sCode, "_"))
bkmk = Left(bkmk, Len(bkmk) - 2)
fld.Select
ActiveDocument.Bookmarks.Add Range:=Selection.Range, _
Name:=bkmk & "R"
Set aRange = ActiveDocument.Bookmarks(bkmk).Range
aRange.Select
With ActiveDocument.Hyperlinks.Add(Anchor:=Selection.Range, _
Address:="", SubAddress:=bkmk & "R", _
TextToDisplay:=Selection.Text)
.Range.Select
Selection.ClearCharacterAllFormatting
End With
End If
Next fld
Options.CtrlClickHyperlinkToOpen = False
Selection.GoTo What:=wdGoToBookmark, Name:="Inhoud"
Application.ScreenUpdating = True
End Sub