Wie kann ich - per Makro - alle in einem Word-Dokument enthaltenen Internetz-Adressen ("www.";"https://";"http://") in einen Hyperlink umwandeln?

[MSCom]

Hallo liebe Forums-User!



Ich versuche einen Makro zu erstellen, der in einem längeren Dokument mehrere beliebige unterschiedliche Webadressen automatisch in Hyperlinks umwandelt.


Problematisch finde ich es, den richtigen Code dafür zu finden.


Ich habe in einem uralten Thread von 2011 in einem anderen Forum* folgenden Code gefunden:

*Link:

Makro Hyperlink erstellen - - - - - - - - - Office-Loesung.de.


Option Explicit
Sub MakeHyperlink()
Dim oRange As Range
Set oRange = ActiveDocument.Range
With oRange.Find
.Text = "http://*.*."
.Wrap = wdFindContinue
.MatchWildcards = True
While .Execute
.Parent.Select
Selection.MoveEnd wdWord, 1
Dim myRange As Range
If Selection.Characters.Last = " " Then
Set myRange = ActiveDocument.Range(Selection.Range.Start, _
Selection.Range.End - 1)
Else
Set myRange = ActiveDocument.Range(Selection.Range.Start, _
Selection.Range.End)
End If
If myRange.Hyperlinks.Count = 1 Then Exit Sub
Dim hLink As String
hLink = myRange.Text
ActiveDocument.Hyperlinks.Add Anchor:=myRange, Address:= _
hLink, SubAddress:="", ScreenTip:="", TextToDisplay:=hLink
Selection.MoveRight wdCharacter, 1
oRange.SetRange Start:=Selection.Range.Start, _
End:=ActiveDocument.Range.End
Wend
End With
End Sub


Leider funktioniert dieser Code nicht (mehr) [zumindest bei mir] und nach dem Inhalt des alten Forumsthreads zu urteilen, soll er auch nur dann Anwendung finden, wenn ein Link markiert wird, während ich will, dass die Funktion von sich aus alle relevanten Stellen findet und in Hyperlinks umwandelt.


Mein "Code" ist dementsprechend nur etwas erweitert bei den Adressen, aber ich weiß nicht, wie ich das so umsetzen kann, wie ich das will.


Sub company_Hyperlinks()

'

' companyMakro

' Inserts hyperlinks

'

Dim oRange As Range

Set oRange = ActiveDocument.Range

With oRange.Find

.Text = "http://*.*."

.Text = "https://*.*."

.Text = "www.*.*"

.Wrap = wdFindContinue

.MatchWildcards = True

While .Execute

.Parent.Select

Selection.MoveEnd wdWord, 1

Dim myRange As Range

If Selection.Characters.Last = " " Then

Set myRange = ActiveDocument.Range(Selection.Range.Start, _

Selection.Range.End - 1)

Else

Set myRange = ActiveDocument.Range(Selection.Range.Start, _

Selection.Range.End)

End If

If myRange.Hyperlinks.Count = 1 Then Exit Sub

Dim hLink As String

hLink = myRange.Text

ActiveDocument.Hyperlinks.Add Anchor:=myRange, Address:= _

hLink, SubAddress:="", ScreenTip:="", TextToDisplay:=hLink

Selection.MoveRight wdCharacter, 1

oRange.SetRange Start:=Selection.Range.Start, _

End:=ActiveDocument.Range.End

Wend

End With

End Sub



Ich würde mich über Hilfe natürlich sehr freuen!