User Tools

Site Tools


vba:functions:rx:index

[VBA] RegExp Functions (RX-Functins)

Eine Sammlung mit Funktionen rund um RegExp

Download RxCached.bas

Insperiert durch PHP mit den Funktion preg_match() preg_match_all(), preg_replace() und preg_replace_callback() habe ich mich mal drangesetzt so was ähnliches mit VBA und der RegExp1)-Klasse umzusetzen. Und das ist dabei herausgekommen.

Notwendie Referenzen

Die Funktion rx_replace_callback() verwendet den MS Access-Befehl eval(). In anderen Applikationen läuft sie nicht. Alternativ kann man die Funktion aus MS Access einbinden (sofern MS Access auf dem Rechner isntalliert ist): [VBA] Eval() und Nz() in MS Excel

Für diese Funktione muss eine Referenz auf Microsoft VBScript Regular Expressions 5.5 gesetzt sein. Alternativ kann man auch alle Definitionen auf Late Binding umbauen.

Das Script wurde vollständig auf Late Bindung umgestellt.

Funktionen

Für die einzelnen Funktionen habe jeweils eine eigene Seite mit Beschreibung und Beispielen eingerichtet. Weiter unten auf dieser Seite befindet sich der Code für alle Funktionen zusammengefasst.

Übergreiffende Definitionen

Enumeratoren

rxFlagsEnum

Dieser Enumerator wird in allen Funktionen verwendet.

'/**
' * Wird für die rx_ Funktionen verwendet
' * Setzte die Flags für das RegExp Object
' */
Public Enum rxFlagsEnum
    rxnone = 2 ^ 0          'Value 1
    rxglobal = 2 ^ 1        'Value 2
    rxIgnorCase = 2 ^ 2     'Value 4
    rxMultiline = 2 ^ 3     'Value 8
End Enum

Setzte die Flags für das RegExp Object. Für das genaue Verhalten bitte die VB-Doku zur RegExp Klasse studieren

  • rxNone Alle Parameter werden auf False gesetzt. Wird vor allem zum überschreiben des Standards gebraucht.
  • rxGlobal Setzt Global2) auf True
  • rxIgnorCase Setzt IgnorCase3) auf True
  • rxMultiline Setzt Multiline auf True

Code

Hier der komplette Code für alle rx-Funktionen. Einmal eine normale Version, in der die RegExp-Objekt nicht gespeichert werden, und einmal mit einem Cache-Speichern der Objekte. Die Zweite Variante ist vor allem dann nützlich, wenn man die Funktionen innerhalb von SQL-Statements verwenden will.

Version ohne Cache

Die Version ohne Cache habe ich entfernt. Ich sehe keinen Grund diese Version zu verwenden.

Version mit Cache

RxCached.bas
'-------------------------------------------------------------------------------
'File         : RxCached
'               Copyright mpl by ERB software
'               All rights reserved
'               http://wiki.yaslaw.info/dokuwiki/doku.php/vba/functions/rx/
'Environment  : VBA 2007 +
'Version      : 1.3.0
'Name         : RxCached
'Author       : Stefan Erb (ERS)
'History      : 08.11.2013 - 1.0.0 - ERS -  Creation
'               12.11.2013 - 1.1.0 - ERS -  RegExp auf Late Bindung umgestellt
'                                           Funktion rx_like() hinzugefügt
'               13.11.2013 - 1.2.0 - ERS -  Funktion rx_choose() hinzugefügt
'                                           rx_match() um rx.test erweitert
'               19.11.2013 - 1.3.0 - ERS -  RxCached aus Rx V1.2 erstellt
'                                           rx_match_array() überarbeitet und auf rx_array() umbenannt
'               07.01.2014 - 1.4.0 - ERS -  rx_escape_string() hinzugefügt
'-------------------------------------------------------------------------------
Option Explicit
 
'/**
' * Wird für die rx_ Funktionen verwendet
' * Setzte die Flags für das RegExp Object
' */
Public Enum rxFlagsEnum
    [_FIRST] = 0
    rxnone = 2 ^ 0          'Value 1
    rxglobal = 2 ^ 1        'Value 2
    rxIgnorCase = 2 ^ 2     'Value 4
    rxMultiline = 2 ^ 3     'Value 8
    [_LAST] = 3
End Enum
 
'/**
' * Wird bei rx_match_array verwendet
' */
Public Enum rxArrayEnum
    [_FIRST] = 0
    rxIncludeMatch = 2 ^ 0          'Der gefundene Gesammtstring wird mit index 0 zurückgegeben
    rxIncludeSubmatches = 2 ^ 1     'Die Submatches werden mit ausgegen. Da entwder rxIncludeMatch
                                    'oder rxIncludeSubmatches ausgewählt sein muss, wird rxIncludeSubmatches
                                    'automatisch selektioniert wenn rxIncludeMatch nicht ausgewählt ist
    rxNoReduceDimensions = 2 ^ 2    'Verbietet die Reduzierung auf ein 1-Dimensionales Array
    [_LAST] = 2
End Enum
 
'/**
' * Pattern mit allen Sonderzeichen die Escapte werden müssen
' */
Private Const C_RX_ESCAPE_PATTERNS = "([\\\*\+\?\|\{\[\(\)\^\$\.\#])"
 
 
'Der RegExpCache
'Das Format sieht so aus Dictionary(Pattern) => Dictionary(Flags) => RegExp
Private cacheRx()       As Object
Private cacheIdx        As Object
Private cacheNextIdxNr  As Long
 
'/**
' * Liest ein RegExp aus dem Cache oder erstellt ihn neu, falls er noch nicht vorhanden ist
' * @param  String          Pattern analog RegExp
' * @param  rxFlagsEnum     Eigenschaften von Regexp. Global, IgnoreCase und Multiline.
' *                         Die Eigenschaften können mit + kombiniert werden
' * @param  Boolean     Bei True wird der Cache von den RegExp zurückgesetzt.
' * @return MatchCollection oder Nothing wenn keine übereinstimmung vorhanden ist
' */
Private Function getRxIndex( _
        ByVal iPattern As String, _
        ByVal iFlags As rxFlagsEnum, _
        Optional ByVal iResetCache As Boolean = False _
) As Long
 
    'Reset
    If iResetCache Then Call resetCacheRx
    'CXreate Cache
    If cacheIdx Is Nothing Then Set cacheIdx = CreateObject("scripting.Dictionary")
    'Create PatternCache
    If Not cacheIdx.Exists(iPattern) Then Call cacheIdx.Add(iPattern, CreateObject("scripting.Dictionary"))
 
    If Not cacheIdx(iPattern).Exists(iFlags) Then
        ReDim Preserve cacheRx(cacheNextIdxNr)
        Call cacheIdx(iPattern).Add(iFlags, cacheNextIdxNr)
 
        'RegExp neu erstellen
        Set cacheRx(cacheNextIdxNr) = CreateObject("VBScript.RegExp")
        With cacheRx(cacheNextIdxNr)
            .Global = iFlags And rxglobal
            .IgnoreCase = iFlags And rxIgnorCase
            .MultiLine = iFlags And rxMultiline
            .pattern = iPattern
        End With
        getRxIndex = cacheNextIdxNr
        cacheNextIdxNr = cacheNextIdxNr + 1
    Else
        'RegExp aus Cache übernehmen
        getRxIndex = cacheIdx(iPattern).Item(iFlags)
    End If
End Function
 
'/**
' * Leert den RegExp-Chache
' */
Public Sub resetCacheRx()
    cacheNextIdxNr = 0
    Set cacheIdx = Nothing
    Erase cacheRx
End Sub
 
'/**
' * Escapte alle Sonderzeichen um eine rx-Pattern zu erstellen
' * @example    rx_escape_string("Hallo Welt. Geht es dir (noch) gut?")
' *             Hallo Welt\. Geht es dir \(noch\) gut\?
' * @param  String
' * @return String
' */
Public Function rx_escape_string( _
        ByVal iString As String _
) As String
    rx_escape_string = rx_replace(C_RX_ESCAPE_PATTERNS, "\$1", iString)
End Function
 
 
'/**
' * Copyright mpl by ERB software | http://wiki.yaslaw.info
' * @doku   http://wiki.yaslaw.info/dokuwiki/doku.php/vba/functions/rx/rx_match
' *
' * Die Idee hatte ich aus PHP. Ein Befehl um ein Reguläreren Ausdruck direkt auszuwerten
' * @example                Set mc = rx_match("([\d\.]+)", "3 Würste unf 4.5 Liter Wasser", pfGlobal)
' * @param  String          Pattern analog RegExp
' * @param  String          Der String der bearbeitet werden soll
' * @param  rxFlagsEnum     Eigenschaften von Regexp. Global, IgnoreCase und Multiline.
' *                         Die Eigenschaften können mit + kombiniert werden
' * @return MatchCollection oder Nothing wenn keine übereinstimmung vorhanden ist
' */
Public Function rx_match( _
        ByVal iPattern As String, _
        ByVal iSubject As String, _
        Optional ByVal iFlags As rxFlagsEnum = rxglobal + rxIgnorCase _
) As Object
    Dim idx As Long: idx = getRxIndex(iPattern, iFlags)
 
    If cacheRx(idx).test(iSubject) Then Set rx_match = cacheRx(idx).execute(iSubject)
End Function
 
'/**
' * Copyright mpl by ERB software | http://wiki.yaslaw.info
' * @doku   http://wiki.yaslaw.info/dokuwiki/doku.php/vba/functions/rx/rx_choose
' *
' * Extrahiert einen Submatch aus einem String
' * @example                monat = print_r rx_choose("(\d{0,2})\.(\d{0,2})\.(\d{0,4})", "01.02.2013", 2)
' * @param  String          Pattern analog RegExp
' * @param  String          Der String der bearbeitet werden soll
' * @param  Integer         Match von dem das Subitem ausgegeben werden soll. Beginnt mit 1
' * @param  Integer         SubMatch der ausgegeben werden soll. Bei 0 wird der gesammte Match ausgegeben Beginnt mit 0
' * @param  rxFlagsEnum     Eigenschaften von Regexp. Global, IgnoreCase und Multiline.
' *                         Die Eigenschaften können mit + kombiniert werden
' * @return Wert oder False
' */
Public Function rx_choose( _
        ByVal iPattern As String, _
        ByVal iSubject As String, _
        Optional ByVal iMatchIndex As Integer = 1, _
        Optional ByVal iSubMatchIndex As Integer = 0, _
        Optional ByVal iFlags As rxFlagsEnum = rxglobal + rxIgnorCase _
) As Variant
    Dim mc      As Object:  Set mc = rx_match(iPattern, iSubject, iFlags)
    Dim idxSm   As Integer: idxSm = iSubMatchIndex - 1
    Dim idxM    As Integer: idxM = iMatchIndex - 1
 
    If Not mc Is Nothing Then
        If mc.Count > idxM And idxM >= 0 Then
            If idxSm = -1 Then
                rx_choose = mc.Item(idxM)
                GoTo Exit_Handler
            ElseIf mc.Item(idxM).SubMatches.Count > idxSm And idxSm >= 0 Then
                rx_choose = mc.Item(idxM).SubMatches(idxSm)
                GoTo Exit_Handler
            End If
        End If
    End If
    rx_choose = False
 
Exit_Handler:
    Set mc = Nothing
End Function
 
'/**
' * Copyright mpl by ERB software | http://wiki.yaslaw.info
' * http://wiki.yaslaw.info/dokuwiki/doku.php/vba/functions/rx/rx_match_array
' *
' * ALias zu rx_match_array()
' */'
Public Function rx_array( _
        ByVal iPattern As String, _
        ByVal iSubject As String, _
        Optional ByVal iFlags As rxFlagsEnum = rxglobal + rxIgnorCase, _
        Optional ByVal iArrayFlags As rxArrayEnum = rxIncludeSubmatches _
) As Variant()
    rx_array = rx_match_array(iPattern, iSubject, iFlags, iArrayFlags)
End Function
 
'/**
' * Copyright mpl by ERB software | http://wiki.yaslaw.info
' * http://wiki.yaslaw.info/dokuwiki/doku.php/vba/functions/rx/rx_match_array
' *
' * Eine Erweiterung zu rx_match. Das Resultat wird als Array ausgegeben.
' * @example                Set mc = rx_match("([\d\.]+)", "3 Würste unf 4.5 Liter Wasser", pfGlobal)
' * @param  String          Pattern analog RegExp
' * @param  String          Der String der bearbeitet werden soll
' * @param  rxFlagsEnum     Eigenschaften von Regexp. Global, IgnoreCase und Multiline.
' *                         Die Eigenschaften können mit + kombiniert werden
' * @param  rxArrayEnum     Angabe was alles ausgegeben werden soll. Die Matches/Submatches
' *                         Die Auswahl kann mit + kombiniert werden
' * @return MatchCollection
' */
Public Function rx_match_array( _
        ByVal iPattern As String, _
        ByVal iSubject As String, _
        Optional ByVal iFlags As rxFlagsEnum = rxglobal + rxIgnorCase, _
        Optional ByVal iArrayFlags As rxArrayEnum = rxIncludeSubmatches _
) As Variant()
    Dim mc          As Object:      Set mc = rx_match(iPattern, iSubject, iFlags)
    Dim flagMatch   As Boolean:     flagMatch = ((iArrayFlags And rxIncludeMatch) = rxIncludeMatch)
    Dim flagSubM    As Boolean:     flagSubM = Not flagMatch Or ((iArrayFlags And rxIncludeSubmatches) = rxIncludeSubmatches)
    Dim flagRedDim  As Boolean:     flagRedDim = ((iArrayFlags And rxNoReduceDimensions) <> rxNoReduceDimensions)
    Dim det()       As Variant
    Dim retArr()    As Variant
    Dim idx As Integer, firstSmIdx As Integer, idxDet As Integer
 
    If mc Is Nothing Then Exit Function
 
    'Return Array dimensionieren
    ReDim retArr(mc.Count - 1)
    'Erster Index für die Submatches definieren
    firstSmIdx = IIf(flagMatch, 1, 0)
    'Detailarray dimensionieren
    ReDim det(firstSmIdx + IIf(flagSubM, mc(0).SubMatches.Count, 0) - 1)
 
    For idx = 0 To mc.Count - 1
        'Wenn nur der Match-Value ausgegeben werden soll, wird es ein Eindimensionaler Array
        If flagRedDim And flagMatch And Not flagSubM Then
            retArr(idx) = mc(idx).VALUE
        Else
            'Match.Values hinzufügen
            If flagMatch Then det(0) = mc(idx).VALUE
            'Submatches hinzufügen
            If flagSubM Then
                For idxDet = 0 To mc(idx).SubMatches.Count - 1
                    det(firstSmIdx + idxDet) = mc(idx).SubMatches(idxDet)
                Next
            End If
            retArr(idx) = det
        End If
    Next
    'Wenn nur ein Treffer
    rx_match_array = IIf(flagRedDim And mc.Count = 1 And IsArray(retArr(0)), retArr(0), retArr)
 
Exit_Handler:
    Set mc = Nothing
End Function
 
'/**
' * Copyright mpl by ERB software | http://wiki.yaslaw.info
' * @doku   http://wiki.yaslaw.info/dokuwiki/doku.php/vba/functions/rx/rx_replace
' *
' * Die Idee hatte ich aus PHP. Ein Befehl für ein Regulärer Ausdruck-Replace ohne Mehrzeiler-Code
' * @example                new_string = rx_replace("([\W])", "_", "Hallo: Welt2!")
' * @param  String          Pattern analog RegExp
' * @param  String          Ersetzungsstring anaog zu RegExp.replace
' * @param  String          Der String der bearbeitet werden soll
' * @param  rxFlagsEnum     Eigenschaften von Regexp. Global, IgnoreCase und Multiline.
' *                         Die Eigenschaften können mit + kombiniert werden
' * @return String
' */
Public Function rx_replace( _
        ByVal iPattern As String, _
        ByVal iReplacement As String, _
        ByVal iSubject As String, _
        Optional ByVal iFlags As rxFlagsEnum = rxglobal + rxIgnorCase _
) As String
    Dim idx As Long: idx = getRxIndex(iPattern, iFlags)
 
    rx_replace = IIf(cacheRx(idx).test(iSubject), cacheRx(idx).Replace(iSubject, iReplacement), iSubject)
End Function
 
'/**
' * Copyright mpl by ERB software | http://wiki.yaslaw.info
' * @doku   http://wiki.yaslaw.info/dokuwiki/doku.php/vba/functions/rx/rx_replace_callback
' *
' * Führt eine Callback-Funktion über alle Trefferelemente aus und ersetzt diese im Text
' * @example            Ein Beispiel. ich habe eine Funktion getMin(v1,v2) welche den kleineren der Beiden Werte zurückgibt.
' *                     Nun will ich in einem Text alle 'zwieschen v1 und v2' damit berechnen lassen und ersetzen
' *                     Print rx_replace_callback("zwieschen (\d) und (\d)", "getMin", "wir haben zwieschen 1 und 4 Biere und zwieschen 5 und 3 Weine")
' *                     Eingabe: 'wir haben zwieschen 1 und 4 Biere und zwieschen 5 und 3 Weine'
' *                     Ausgabe: 'wir haben 1 Biere und 3 Weine'
' * @param  String      Pattern analog RegExp
' * @param  String      Name der Callback-Funktion
' * @param  String      Der String der bearbeitet werden soll
' * @param  rxFlagsEnum Eigenschaften von Regexp. Global, IgnoreCase und Multiline.
' *                     Die Eigenschaften können mit + kombiniert werden
' * @return String
' */
Public Function rx_replace_callback( _
        ByVal iPattern As String, _
        ByRef iCallback As Variant, _
        ByVal iSubject As String, _
        Optional ByVal iFlags As rxFlagsEnum = rxglobal + rxIgnorCase _
) As String
    Dim mc      As Object:  Set mc = rx_match(iPattern, iSubject, iFlags) 'MatchCollection
    Dim m       As Object   'Match
    Dim smc()   As String
    Dim ret     As String
    Dim i, k
 
    rx_replace_callback = iSubject
    For i = mc.Count - 1 To 0 Step -1
        Set m = mc.Item(i)
        'Alle Submatches zu Argumenten zusammenführen
        ReDim smc(m.SubMatches.Count - 1)
        For k = 0 To UBound(smc): smc(k) = """" & m.SubMatches(k) & """": Next k
        ret = CStr(Evaluate(iCallback & "(" & Join(smc, ",") & ")"))
        'Unterstring ersetzen
        rx_replace_callback = Left(rx_replace_callback, m.FirstIndex) & ret & Mid(rx_replace_callback, m.FirstIndex + m.Length + 1)
    Next i
 
    Set m = Nothing
    Set mc = Nothing
End Function
 
'/**
' * Copyright mpl by ERB software | http://wiki.yaslaw.info
' * @doku   http://wiki.yaslaw.info/dokuwiki/doku.php/vba/functions/rx/rx_like
' *
' * Führt den RegExp.test() aus und gibt ein Boolean zurück, falls das Pattern greift
' * @example                new_string = rx_replace("([\W])", "_", "Hallo: Welt2!")
' * @param  String          Pattern analog RegExp
' * @param  String          Der String der getestet werden soll
' * @param  rxFlagsEnum     Eigenschaften von Regexp. Global, IgnoreCase und Multiline.
' *                         Die Eigenschaften können mit + kombiniert werden
' * @return Boolean
' */
Public Function rx_like( _
        ByVal iPattern As String, _
        ByVal iSubject As String, _
        Optional ByVal iFlags As rxFlagsEnum = rxIgnorCase _
) As Boolean
    rx_like = cacheRx(getRxIndex(iPattern, iFlags)).test(iSubject)
End Function

Internas: Aufbau des Chaches

Der Cache speichert die RegExp-Objekte für alle Rx-Funktionen. Wenn an also ein rx_like() und anschliessend ein rx_choose() ausführt, greifen diese auf denselben Cache zu

Am besten zeige ich an einem Beispiel, wie der Chache aufgebaut ist.

Zuerst führe ich drei Funktionen aus. 2mal mit demselben Pattern aber unterschiedliche Paramterern und einmal mit eine anderen Pattern

print_r rx_like("abc", "Hans dampf im Schnaggäloch, hät alles was er will")
<Boolean> False
 
print_r rx_like("abc", "Hans dampf im Schnaggäloch, hät alles was er will", rxIgnorCase+rxglobal+rxMultiline)
<Boolean> False
 
print_r rx_match("[a-z](l{2})", "Hans dampf im Schnaggäloch, hät alles was er will",rxglobal+rxIgnorCase)
<IMatchCollection2> (
    [0] => <IMatch2> (
        [Match] => <String> 'all'
        [0] => <String> 'll'
    )
    [1] => <IMatch2> (
        [Match] => <String> 'ill'
        [0] => <String> 'll'
    )
)

Dictionary cacheIdx

Der Index ist ein 2-Dimensionales Dictionary. Die erste Dimension hat als Key den Pattern. Die Zweite die Summe der Flags (Enum rxFlagsEnum). Als Value ist dann der Index aus dem Array cacheRx hinterlegt.

print_r cacheIdx
<Dictionary> (
    [abc] => <Dictionary> (
        [4] => <Long> 0
        [14] => <Long> 1
    )
    [[a-z](l{2})] => <Dictionary> (
        [6] => <Long> 2
    )
)

Array<IRegExp2> cacheRx

Dieser Array speichert alle RegExp-Objekte.

print_r cacheRx
<Object()> (
    [0] => <IRegExp2> (
        [Pattern] => <String> 'abc'
        [Global] => <Boolean> False
        [IgnoreCase] => <Boolean> True
        [Multiline] => <Boolean> False
    )
    [1] => <IRegExp2> (
        [Pattern] => <String> 'abc'
        [Global] => <Boolean> True
        [IgnoreCase] => <Boolean> True
        [Multiline] => <Boolean> True
    )
    [2] => <IRegExp2> (
        [Pattern] => <String> '[a-z](l{2})'
        [Global] => <Boolean> True
        [IgnoreCase] => <Boolean> True
        [Multiline] => <Boolean> False
    )
)
vba/functions/rx/index.txt · Last modified: 29.04.2015 11:12:48 by yaslaw