Option Explicit
Const c_Feldtyp As String = HYPERLINK
'***************************************************
Sub HYPERLINKS_DurchAngezeigtenTextErsetzen()
->im aktiven Dokument werden alle Hyperlinks
->durch den momentan angezeigten Text ersetzt
'***************************************************
Dim f As Field
For Each f In ActiveDocument.Fields
If c_Feldtyp = Left(f.Code, Len(c_Feldtyp)) Then
f.Unlink
End If
Next
End Sub
'***************************************************
Sub HYPERLINKS_KomplettEntfernen()
->im aktiven Dokument werden alle Hyperlinks
->komplett entfernt
->(vorhergehendes Leerzeichen wird mitentfernt,
-> wenn ein Punkt, Komma, Doppelpunkt, Semikolon
-> oder Leerzeichen folgt)
'***************************************************
Dim f As Field, s_tmp As String
For Each f In ActiveDocument.Fields
If c_Feldtyp = Left(f.Code, Len(c_Feldtyp)) Then
f.Select
f.Delete
->nachfolgendes Zeichen untersuchen
Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
s_tmp = Selection.Text
Select Case s_tmp
Case ., ,, :, ;, ->bei nachfolgendem .,:;Leerzeichen
->vorhergehendes Leerzeichen entfernen,wenn vorhanden
Selection.MoveLeft Unit:=wdCharacter, Count:=1
Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
If Selection.Text = Then Selection.Delete
End Select
End If
Next
End Sub
'***************************************************
Sub HYPERLINKS_Entfernen_MitAbfrage()
->im aktiven Dokument werden alle Hyperlinks
->abgefragt, ob sie
->- komplett gelöscht
->- durch den angezeigten Text ersetzt
->- übersprungen
->werden sollen
'***************************************************
Dim f As Field, s_tmp As String, ret As Integer
For Each f In ActiveDocument.Fields
If c_Feldtyp = Left(f.Code, Len(c_Feldtyp)) Then
f.Select
ret = MsgBox( _
Wollen Sie den Hyperlink & vbCrLf & vbCrLf & _
- komplett entfernen -> Ja & vbCrLf & _
- ersetzen durch den angezeigten Text -> Nein & vbCrLf & _
- überspringen -> Abbrechen, _
vbQuestion + vbYesNoCancel + vbDefaultButton3)
If ret = vbYes Then->Ja???
->komplett löschen
f.Delete
->nachfolgendes Zeichen untersuchen
Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
s_tmp = Selection.Text
Select Case s_tmp
Case ., ,, :, ->bei nachfolgendem .,:Leerzeichen
->vorhergehendes Leerzeichen entfernen,wenn vorhanden
Selection.MoveLeft Unit:=wdCharacter, Count:=1
Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
If Selection.Text = Then Selection.Delete
End Select
ElseIf ret = vbNo Then->Nein???
f.Unlink->durch angezeigten text ersetzen
Else
->Überspringen
End If
End If
Next
End Sub
