'------------------------------------------------------------------------------- '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