Word - Abkürzungen identifizieren

Am Ende eines Berichts soll ein Abkürzungsverzeichnis erstellt werden. Die Suche nach den Abkürzungen kann sehr mühevoll sein. Abhilfe mit VBA: Dieses Skript durchsucht das Dokument nach Abkürzungen. Wichtig! Abkürzungen sind im Text wie folgt einzuführen: Visual Basis for Application (VBA).

Die Funktion PrintAbbreviations erzeugt eine Liste aller Abkürzungen im Direktbereich.

Option Explicit
Option Base 1
' Extras -> Verweise -> Microsoft VBScript Regular Expressions 5.5

Sub PrintAbbreviations()
Dim txt As String
Dim Abbreviations() As String
Dim i As Integer

    txt = ActiveDocument.Range.Text
    Abbreviations = GetAbbreviations(txt)
    
    For i = 1 To UBound(Abbreviations)
        Debug.Print Abbreviations(i)
    Next

End Sub

Function GetAbbreviations(txt As String) As String()
' Suche im Dokument nach Text ohne Leerzeichen in Klammern () => Potenzielle Abkürzungen

Dim objRegExp As RegExp
Dim objMatch As Match
Dim colMatches As MatchCollection
Dim keys() As String
Dim i As Integer

Dim NoAbbrevations() As String
NoAbbrevations = Split("links,rechts,oben,unten,schwarz", ",")

    'Create a regular expression object.
    Set objRegExp = New RegExp
    ReDim keys(100)
    i = 1
    
    'Set the pattern by using the Pattern property.
    objRegExp.Pattern = "(?!\([0-9]*\))(\(([a-zA-Z0-9]*)\))"
     
    'Set Case Insensitivity.
    objRegExp.IgnoreCase = True

    'Set global applicability.
    objRegExp.Global = True

    'Test whether the String can be compared.
    If (objRegExp.Test(txt) = True) Then

    'Get the matches.
    Set colMatches = objRegExp.Execute(txt)   ' Execute search.
           
    For Each objMatch In colMatches   'Iterate Matches collection.
      If Not Contains(keys, objMatch.SubMatches(1)) _
      And Not Contains(NoAbbrevations, objMatch.SubMatches(1)) _
      And Len(objMatch.SubMatches(1)) < 8 Then
        keys(i) = objMatch.SubMatches(1)
        i = i + 1
      End If
      If i Mod 100 = 0 Then
        ReDim Preserve keys(UBound(keys) + 100)
      End If
    Next
   End If
   ReDim Preserve keys(i - 1)
   
   GetAbbreviations = keys
End Function

Public Function Contains(liste() As String, str As String) As Boolean
Dim i As Integer
On Error GoTo err

    Contains = False
    For i = LBound(liste) To UBound(liste)
        If liste(i) = str Then
            Contains = True
            Exit Function
        End If
    Next
    
err:
    Contains = False
End Function
Your rating: Keine