Option
Explicit
Private
Type UFigure
Range
As
Word.Range
Id
As
Long
Description
As
String
End
Type
Public
Sub
AbbVerzeichnis()
Dim
udtFigures()
As
UFigure
Dim
abbildungsverzeichnis
As
String
Dim
i
As
Long
For
i = 1
To
GetListOfFigures(ActiveDocument.Content, udtFigures)
abbildungsverzeichnis = abbildungsverzeichnis &
"Abbildung "
& udtFigures(i).Id &
": "
& udtFigures(i).Description & vbNewLine
Next
MsgBox abbildungsverzeichnis
End
Sub
Private
Function
GetListOfFigures(Range
As
Word.Range,
ByRef
Figures()
As
UFigure)
As
Long
Dim
matches
As
Object
With
CreateObject(
"VBScript.RegExp"
)
.Global =
True
.MultiLine =
True
.IgnoreCase =
True
.Pattern =
"Abb\. (\d+): ([^\r\n]+)"
Set
matches = .Execute(Range.Text)
End
With
If
matches.Count = 0
Then
Exit
Function
End
If
Dim
match
As
Object
Dim
i
As
Long
ReDim
Figures(1
To
matches.Count)
For
i = 1
To
matches.Count
Set
match = matches(i - 1)
With
Figures(i)
Set
.Range = Range.Document.Range(match.FirstIndex, match.FirstIndex + match.Length)
.Id =
CLng
(match.SubMatches(0))
.Description = match.SubMatches(1)
End
With
Next
GetListOfFigures = matches.Count
End
Function