Download udf_rxmatch.bas (V-1.0.0)

udf_rxmatch.bas

Attribute VB_Name = "udf_rxMatch"
'-------------------------------------------------------------------------------
'File         : udf_rxMatch.bas
'               Copyright mpl by ERB software
'               All rights reserved
'               wiki.yaslaw.info/dokuwiki/doku.php/vba/functions/rxmatch
'Environment  : VBA 2010 +
'Version      : 1.0.0
'Name         : udf_rxMatch
'Author       : Stefan Erb (ERS)
'History      : 03.10.2016 - ERS - Creation udf_rxMatch
'-------------------------------------------------------------------------------
Option Explicit
 
'/**
' * Prüft ob ein Value auf eon Pattern passt. Die RegExp-Objekte werden gecached.
' * Ist geeignet für die Anwendung in SQL.
' * @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. Wenn in einem SQL mehrere rxMatch verwendet werden, kann man diese durchnumerieren
' * @return Boolean
' */
Public Function rxMatch(ByVal iValue As Variant, ByVal iPattern As String, Optional ByVal iIndex As Long = 0) As Boolean
    Static isInitilaize As Boolean
    Static pattern() As String
    Static lastIdx As Long
    Static rx() As Object
 
    If lastIdx < iIndex Or (lastIdx = 0 And iIndex = 0 And isInitilaize = False) Then
        lastIdx = iIndex
        ReDim Preserve pattern(lastIdx): pattern(lastIdx) = iPattern
        ReDim Preserve rx(lastIdx): Set rx(lastIdx) = cRx(iPattern)
        isInitilaize = True
    ElseIf pattern(iIndex) <> iPattern Then
        pattern(iIndex) = iPattern
        Set rx(iIndex) = cRx(iPattern)
    End If
 
    rxMatch = rx(iIndex).test(NZ(iValue))
End Function
 
'-------------------------------------------------------------------------------
' -- 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