Yaslaw.Info

This page is read only. You can view the source, but not change it. Ask your administrator if you think this is wrong.
====== [VBA] RegExp Functions (RX-Functins) ======
//Eine Sammlung mit Funktionen rund um RegExp//

{{:vba:functions:rxcached.bas|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 <nowiki>RegExp</nowiki>(([[http://msdn.microsoft.com/en-us/library/yab2dx62%28v=vs.84%29.aspx|RegExp bei MSDN]]))-Klasse
umzusetzen. Und das ist dabei herausgekommen.

===== Notwendie Referenzen =====
<wrap hi>Die Funktion rx_replace_callback() verwendet den MS Access-Befehl eval(). In anderen Applikationen läuft
 sie nicht.</wrap> Alternativ kann man die Funktion aus MS Access einbinden (sofern MS Access auf
dem Rechner isntalliert ist): [[:vba:accessfunctionsinexcel]]

<del>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.</del>
>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.
  ***[[.:rx_choose]]** Gibt einen Extrahierten Teil des Strings zurück
  ***[[.:rx_like]]** Das Subjekt nur gegen den Regulären Ausdruck prüfen
  ***[[.:rx_match]]** Ein Befehl um ein Reguläreren Ausdruck direkt auszuwerten.
  ***[[.:rx_match_array]]**  Eine Erweiterung zu rx_match. Das Resultat wird als Array ausgegeben.
  ***[[.:rx_replace]]**  Ein Befehl für ein Regulärer Ausdruck-Replace ohne Mehrzeiler-Code
  ***[[.:rx_replace_callback]]**  Führt eine Callback-Funktion über alle Trefferelemente aus und ersetzt diese im Text
  ***[[.:rx_escape_string]]**  Eine Hilfsfunktion um Spezialcharakters zu escapen um ein Pattern zusammenzusetzen.

===== Übergreiffende Definitionen =====
==== Enumeratoren ====
=== rxFlagsEnum ===
Dieser Enumerator wird in allen Funktionen verwendet.
<code vb>'/**
' * 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</code>

<nowiki>Setzte die Flags für das RegExp Object. Für das genaue Verhalten bitte die VB-Doku zur RegExp Klasse studieren</nowiki>
  ***rxNone** Alle Parameter werden auf False gesetzt. Wird vor allem zum überschreiben des Standards gebraucht.
  ***rxGlobal** Setzt Global(([[http://msdn.microsoft.com/en-us/library/tdte5kwf(v=vs.84).aspx|Global Property auf MSDN]])) auf True
  ***rxIgnorCase**  Setzt <nowiki>IgnorCase</nowiki>(([[http://msdn.microsoft.com/en-us/library/wy1d4bz3(v=vs.84).aspx|IgnorCase Property auf MSDN]])) auf True
  ***rxMultiline**  Setzt Multiline auf True

===== Code =====
Hier der komplette Code für alle rx-Funktionen.
Einmal eine normale Version, in der die <nowiki>RegExp</nowiki>-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 ====
<code vb 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</code>

===== Internas: Aufbau des Chaches =====
Der Cache speichert die <nowiki>RegExp</nowiki>-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
<code vb>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'
    )
)</code>

==== 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.
<code vb>print_r cacheIdx
<Dictionary> (
    [abc] => <Dictionary> (
        [4] => <Long> 0
        [14] => <Long> 1
    )
    [[a-z](l{2})] => <Dictionary> (
        [6] => <Long> 2
    )
)</code>

==== Array<IRegExp2> cacheRx ====
Dieser Array speichert alle <nowiki>RegExp</nowiki>-Objekte.
<code vb>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
    )
)</code>


{{tag>vba:Functions vba:RegExp  VBA}}
Yaslaw.Info

User Tools

Site Tools

Page Tools
