Public
Sub
AlleHyperlinkseinesDocsauflösen()
Selection.HomeKey Unit:=wdStory
While
ActiveDocument.Hyperlinks.Count > 0
ActiveDocument.Hyperlinks(1).Delete
Wend
End
Sub
Sub
AlleHyperlinksDokumente()
Dim
i
As
Integer
Dim
Verzeichnis
As
String
Dim
MeinHyper
As
Hyperlink
Dim
MeinTeil
As
Range
Dim
Teil
As
Variant
Dim
objFile
As
Scripting.File
Dim
fs
As
New
Scripting.FileSystemObject
With
Dialogs(wdDialogCopyFile)
.Show
Verzeichnis = .Directory
End
With
For
Each
objFile
In
fs.GetFolder(Verzeichnis).Files
Debug.Print objFile.Name
If
FileExtension(objFile.Name) =
".dotx"
Then
Documents.Open objFile.Name
Application.ScreenUpdating =
False
ActiveDocument.Repaginate
For
Each
Teil
In
ActiveDocument.StoryRanges
Teil.Fields.Update
While
Not
(Teil.NextStoryRange
Is
Nothing
)
Set
Teil = Teil.NextStoryRange
For
Each
MeinHyper
In
MeinTeil.Hyperlinks
MeinHyper.Delete
Teil.Fields.Update
Next
Wend
Next
Application.ScreenUpdating =
True
For
Each
MeinTeil
In
ActiveDocument.StoryRanges
For
Each
MeinHyper
In
MeinTeil.Hyperlinks
MeinHyper.Delete
Next
Next
ActiveDocument.Close SaveChanges:=wdSaveChanges
End
If
Next
End
Sub
Function
FileExtension(File
As
String
)
As
String
Dim
regEx
As
New
RegExp
Dim
mc
As
MatchCollection
With
regEx
.Global =
True
.IgnoreCase =
True
.Pattern =
"(\.\w+)$"
If
.Test(File)
Then
Set
mc = regEx.Execute(File)
FileExtension = mc.Item(0).Value
End
If
End
With
End
Function