Attribute VB_Name = "lib_rxLib" '------------------------------------------------------------------------------- 'File : lib_rxLib.bas ' Copyright mpl by ERB software ' All rights reserved ' wiki.yaslaw.info/dokuwiki/doku.php/vba/functions/rxlib 'Environment : VBA 2010 + 'Version : 1.0.0 'Name : lib_rxLib 'Author : Stefan Erb (ERS) 'History : 03.10.2016 - ERS - Creation udf_rxMatch '------------------------------------------------------------------------------- Option Explicit ' Eine Sammlung von RegExp-Funktionen um innerhalb eines SQL-Statements verwendet zu werden. ' Es können mehrere RegExp-Objekte initialziert und gecached werden. Private Const C_CACHE_TIMEOUT = 300 'Sekunden '------------------------------------------------------------------------------- ' -- Public Methodes '------------------------------------------------------------------------------- '/** ' * Prüft ob ein Value auf eon Pattern passt. Die RegExp-Objekte werden gecached. Interessant für SQL ' * Ist geeignet für die Anwendung in SQL. ' * ' * @example rxMatch("infa@yaslaw.info", "/@.*\.INFO$/i") = True ' * ' * @param Variant Wert, der geprüft werden soll ' * @param String Reg-Exp-Pattern gemäss cRx(): http://wiki.yaslaw.info/dokuwiki/doku.php/vba/cast/cregexp#beispiele_mit_patterns_inkl_den_parametern ' * @return Boolean ' */ Public Function rxMatch( _ ByVal iValue As Variant, _ Optional ByVal iPattern As String = Empty _ ) As Boolean On Error GoTo Err_Handler rxMatch = rxCache(iPattern).test(NZ(iValue)) Exit Function Err_Handler: Err.Raise Err.Number, Err.source & ".rxMatch", "rxMatch: " & Err.Description End Function '/** ' * Prüft ob ein Value auf ein Pattern passt. Die RegExp-Objekte werden gecached. Interessant für SQL. ' * Es wird nur der erste Treffer berücksichtigt ' * Ist geeignet für die Anwendung in SQL. ' * ' * @example rxLookup("Er sagte ""Hallo 'schöne' Welt""","/(['""])([^\1]+)\1/i",1) => Hallo 'schöne' Welt ' * rxLookup("Sie sagte 'Grüss dich ""altes Haus""'","/(['""])([^\1]+)\1/i",1) => Grüss dich "altes Haus" ' * ' * @param Variant Wert, der geprüft werden soll ' * @param String Reg-Exp-Pattern gemäss cRx(): http://wiki.yaslaw.info/dokuwiki/doku.php/vba/cast/cregexp#beispiele_mit_patterns_inkl_den_parametern ' * @param Long Index des SubMatches des ersten Treffers: rxObject.execute(iPattern)(0).SubMatches(iPosition). Bei -1 wird der geammte Treffer ausgegeben ' * @return Boolean ' */ Public Function rxLookup( _ ByVal iValue As Variant, _ Optional ByVal iPattern As String = Empty, _ Optional ByVal iPosition As Long = 0 _ ) As String On Error GoTo Err_Handler Dim rx As Object: Set rx = rxCache(iPattern) If rx.test(NZ(iValue)) Then If iPosition = -1 Then rxLookup = rx.execute(NZ(iValue))(0).value Else rxLookup = rx.execute(NZ(iValue))(0).subMatches(iPosition) End If End If Exit Function Err_Handler: Err.Raise Err.Number, Err.source & ".rxLookup", "rxLookup: " & Err.Description End Function '/** ' * Wendet den Replacebefehl an ' * Ist geeignet für die Anwendung in SQL. ' * ' * @example rxReplace("Hallo Welt", "/\s+(WELT)/i", " schöne '$1'") => Hallo schöne 'Welt' ' * ' * @param Variant Wert, der geprüft werden soll ' * @param String Reg-Exp-Pattern gemäss cRx(): http://wiki.yaslaw.info/dokuwiki/doku.php/vba/cast/cregexp#beispiele_mit_patterns_inkl_den_parametern ' * @param String Replace-Value geäss RegExp ' * @return Boolean ' */ Public Function rxReplace( _ ByVal iValue As Variant, _ Optional ByVal iPattern As String = Empty, _ Optional ByVal iReplace As String = Empty _ ) As String On Error GoTo Err_Handler rxReplace = rxCache(iPattern).Replace(NZ(iValue), iReplace) Exit Function Err_Handler: Err.Raise Err.Number, Err.source & ".rxReplace", "rxReplace: " & Err.Description End Function '/** ' * leert den cache der RegExp-Objekte ' */ Public Sub rxResetCache() Dim dummy As Object: Set dummy = rxCache(, True) End Sub '------------------------------------------------------------------------------- ' -- Private Properties '------------------------------------------------------------------------------- '/** ' * Verwaltet die RegExp Objekte ' * @param String Reg-Exp-Pattern gemäss cRx(): http://wiki.yaslaw.info/dokuwiki/doku.php/vba/cast/cregexp#beispiele_mit_patterns_inkl_den_parametern ' * @param Boolean Den Cache zurücksetzen ' * @return RegExp ' */ Private Property Get rxCache( _ Optional ByVal iPattern As String = Empty, _ Optional ByVal iReset As Boolean = False _ ) As Object Static cache As Dictionary ' Static handler As Dictionary On Error GoTo Err_Handler If cache Is Nothing Or iReset Then Set cache = CreateObject("scripting.Dictionary") ' If handler Is Nothing Or iReset Then Set handler = CreateObject("scripting.Dictionary") If iPattern = Empty Then Exit Property If Not cache.exists(iPattern) Then cache.add iPattern, cRx(iPattern) ' handler.add iPattern, Now End If If cache(iPattern) Is Nothing Then Set cache(iPattern) = cRx(iPattern) ' handler(iPattern) = Now End If Set rxCache = cache(iPattern) ' handler(iPattern) = Now ' 'Cache aufräumen ' Dim keys() As Variant: keys = handler.keys ' Dim key As Variant: For Each key In keys ' If DateDiff("s", handler(key), Now) > C_CACHE_TIMEOUT Then ' cache.remove (key) ' handler.remove (key) ' End If ' Next key Exit Property Err_Handler: Err.Raise Err.Number, Err.source, Err.Description End Property '------------------------------------------------------------------------------- ' -- Libraries '------------------------------------------------------------------------------- '/** ' * Dies ist die Minimalversion von cRegExp ' * http://wiki.yaslaw.info/dokuwiki/doku.php/vba/cast/cregexp#abgespeckte_version ' * mögliche Delemiter: @&!/~#=\| ' * mögliche Modifiers: g (Global), i (IgnoreCode), m (Mulitline) ' * ' * @example myRx = cRx("/([a]{2,})/i") 'Finde alle folgen von a. Flag:IgnoreCase ' * @version 2.1.0 (01.12.2014) ' * @param String Pattern mit Delimiter und Modifier analog zu PHP ' * @return Object RegExp-Object ' */ Private Function cRx(ByVal iPattern As String) As Object Static rxP As Object: Set cRx = CreateObject("VBScript.RegExp") If rxP Is Nothing Then: Set rxP = CreateObject("VBScript.RegExp"): rxP.pattern = "^([@&!/~#=\|])?(.*)\1(?:([Ii])|([Gg])|([Mm]))*$" Dim sm As Object: Set sm = rxP.execute(iPattern)(0).subMatches cRx.pattern = sm(1): cRx.IgnoreCase = Not isEmpty(sm(2)): cRx.Global = Not isEmpty(sm(3)): cRx.Multiline = Not isEmpty(sm(4)) End Function