Public VarPath As String
Public VarSearch As String
Public VarReplace As String
 
Sub HyperlinksAuslesen()
  Dim oStory As Range, nDoc As Document
  Dim oTable As Table, oCell As Cell, oRange As Range
  Dim strText As String
  strText = ""
  For Each oStory In ActiveDocument.StoryRanges
    HyperlinksAuslesenNextStory oStory, strText
    While Not (oStory.NextStoryRange Is Nothing)
      Set oStory = oStory.NextStoryRange
      HyperlinksAuslesenNextStory oStory, strText
    Wend
  Next
  If strText = "" Then
    MsgBox "Das Dokument beinhaltet keine Hyperlinks.", vbInformation
    Exit Sub
  End If
 
End Sub
 
Private Sub HyperlinksAuslesenNextStory(oStory As Range, strText As String)
  Dim HL As Hyperlink, otoc As TableOfContents
  Dim VarHlText, VarHlAddress As String
  Dim VarSearch As String
  Dim VarReplace As String
  Dim Flag As Boolean
 
  For Each HL In oStory.Hyperlinks
    Flag = False
    If oStory.StoryType = wdMainTextStory Then
      'Testen ob dies ein interner Hyperlink aus dem Inhaltsverzeichnis ist
      For Each otoc In ActiveDocument.TablesOfContents
        If HL.Range.InRange(otoc.Range) Then
          Flag = True
          Exit For
        End If
      Next
    End If
    If Flag = False Then
      If Val(Left(Application.Version, 1)) = 8 Then 'HL-Eigenschaften für WD97
        strText = strText & HL.Range.Text & vbTab & HL.Address & vbTab & _
           HL.SubAddress & vbCrLf
      Else 'Hyperlink-Eigenschaften ab WD2000
        strText = strText & HL.Range.Text & vbTab & HL.Address & vbTab & _
           HL.SubAddress & vbTab & HL.ScreenTip & vbCrLf
        'Testausgabe_______________________________________
 
        VarHlText = HL.Range.Text
        VarHlAddress = HL.Address
 
       End If
    End If
 
    Dim anz As Long
    anz = anz + 1
    If Documents("Test.doc").Hyperlinks.Count >= anz Then
 
    Selection.Find.ClearFormatting
    With Selection.Find
        .Text = VarSearch
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute
    Selection.Range.Hyperlinks(1).Range.Fields(1).Result.Select
    Selection.Range.Hyperlinks(1).Delete
 
    Dim VarSearchAnz As Long
    Dim VarHlAddressAnz As Long
 
    VarHlAddressAnz = Len(VarHlAddress)
    VarSearchAnz = Len(VarSearch)
    VarHlAddress = Mid(VarHlAddress, VarSearchAnz, VarHlAddressAnz)
 
    ActiveDocument.Hyperlinks.Add Anchor:=Selection.Range, Address:= _
        VarReplace & VarHlAddress, SubAddress:="", ScreenTip:="", _
        TextToDisplay:= _
        VarReplace & VarHlAddress
    Selection.Collapse Direction:=wdCollapseEnd
    End If
 
  Next
 
End Sub