regExp Klasse - reguläre Ausdrücke

1. Diese Klasse ist eine Erweiterung der Funktion rgxValidate von John Nurick.
   
2. Die Patterns von John Nurick habe ich nicht getestet.
3. Man kann einfache Patterns benutzen: * wird intern zu .* umgewandelt.
4. Patterns werden mit ^PATTERN$ ersetzt.

Bsp:

Dim oRegExp As regExp : oRegExp = new regExp
Dim ret As Boolean
 
oRegExp.addPattern "*abc*"
oRegExp.addPattern "*def*"
 
ret = oRegExp.RunOr( "123abc" )    'liefert True
ret = oRegExp.RunOr( "123abc123" ) 'liefert True
ret = oRegExp.RunOr( "123ab123" )  'liefert False
ret = oRegExp.RunOr( "123def" )    'liefert True
 
ret = oRegExp.RunAnd( "123abc123def123" ) 'liefert True
ret = oRegExp.RunAnd( "123abc123" )       'liefert False
 
'Sinnfrei
oRegExp.addPattern "abc*"
oRegExp.addPattern "def*"
ret = oRegExp.RunAnd( "egail_was_hier_steht" )       'liefert IMMER False
'

regExp.cls

Private prPatterns() As String
Private prIsInitPatterns As Boolean
 
 
''' contructor private
''' called on craete Instacne
Private Sub Class_Initialize()
    prIsInitPatterns = False
End Sub
 
Public Function addPattern(ByVal pattern As String) As Boolean
    Dim index As Integer
    If prIsInitPatterns Then
        index = UBound(prPatterns)
        index = index + 1
        ReDim Preserve prPatterns(index)
    Else
        index = 0
        ReDim prPatterns(index)
        prIsInitPatterns = True
    End If
    prPatterns(index) = pattern
End Function
 
Public Function RunAnd(ByVal str As String) As Boolean
    Dim ret As Boolean: ret = True
    On Error GoTo errHandlerRunError
    Dim pattern As String
    For Each tmp In prPatterns
        pattern = tmp
        If easyRegExp(str, pattern) = False Then
            ret = False
            Exit For
        End If
    Next
    GoTo errHandlerRunOK
errHandlerRunError:
    ret = False
errHandlerRunOK:
    RunAnd = ret
    Exit Function
End Function
 
 
Public Function RunOr(ByVal str As String) As Boolean
    Dim ret As Boolean: ret = False
    On Error GoTo errHandlerRunError
    Dim pattern As String
    For Each tmp In prPatterns
        pattern = tmp
        If easyRegExp(str, pattern) = True Then
            ret = True
            Exit For
        End If
    Next
    GoTo errHandlerRunOK
errHandlerRunError:
    ret = False
errHandlerRunOK:
    RunOr = ret
End Function
 
 
Function easyRegExp(ByVal str As String, ByVal search As String) As Boolean
    Dim tmpString As String
    Dim start As Integer
    start = 1
    tmpString = search
    While replaceDot(tmpString, start): Wend
    start = 1
    While replaceWildcard(tmpString, start): Wend
    easyRegExp = rgxValidate(str, tmpString, False, True)
End Function
 
Private Function replaceWildcard(ByRef inString As String, ByRef start As Integer) As Boolean
    Dim pos As Integer
    pos = InStr(start, inString, "*")
 
    If pos > 0 Then
        If pos = 1 Then
            inString = "." & inString
            start = pos + 2
            replaceWildcard = True
        Else
            Dim parentChar As String
            parentChar = Mid(inString, pos - 1, 1)
            If parentChar = "\" Then
                start = pos + 1
                replaceWildcard = True
            Else
                Dim partA As String
                Dim partB As String
                partA = Mid(inString, 1, pos - 1)
                partB = Mid(inString, pos)
                inString = partA & "." & partB
                start = pos + 2
                replaceWildcard = True
            End If
        End If
    Else
        replaceWildcard = False
    End If
End Function
 
Private Function replaceDot(ByRef inString As String, ByRef start As Integer) As Boolean
    Dim pos As Integer
    pos = InStr(start, inString, ".")
 
    If pos > 0 Then
        If pos = 1 Then
            inString = "\" & inString
            start = pos + 2
            replaceDot = True
        Else
            Dim parentChar As String
            parentChar = Mid(inString, pos - 1, 1)
            If parentChar = "\" Then
                start = pos + 1
                replaceDot = True
            Else
                Dim partA As String
                Dim partB As String
                partA = Mid(inString, 1, pos - 1)
                partB = Mid(inString, pos)
                inString = partA & "\" & partB
                start = pos + 2
                replaceDot = True
            End If
        End If
    Else
        replaceDot = False
    End If
End Function
 
Private Function rgxValidate( _
                Target As Variant, _
                pattern As String, _
                Optional CaseSensitive As Boolean = False, _
                Optional MatchWholeString As Boolean = True, _
                Optional FailOnError As Boolean = True) _
                As Boolean
 
                'Returns True if Target matches the regular
                'expression Pattern.
 
                'By John Nurick, October 2002 - January 2003
                '©2003 John Nurick
 
                'NOTES:
 
                'Target will normally be a String. If Target is Null,
                'rgxValidate returns False. Otherwise if Target cannot be
                'converted to a string with CStr(), rgxValidate fails
                'with Error 13, Type Mismatch.
 
                'Pattern should be a VBScript regular expression. See VBScript
                'help file and other documentation for information.
 
                'CaseSensitive does the expected.
 
                'MatchWholeString: if False, rgxValidate returns True if any
                'substring of Target matches Pattern. If True or omitted,
                'the function only returns True if the whole of Target
                'matches Pattern.
                ' E.g. Target "12345" only matches Pattern "234" if
                ' MatchWholeString is False.
 
                'FailOnError: if this is True or omitted, rgxValidate passes
                'any run time error to the calling procedure. If it is False,
                'the function returns True on a successful match and False if
                'the match fails for any reason including a run time error.
 
                'rgxValidate is suitable for use in data entry forms and the
                'like. It can also be used in queries and in looping through
 
                'recordsets, but because it creates a RegExp object and compiles
                'the regular expression (Pattern) every time it is called,
                'it is rather inefficient for repetitive operations.
 
                'Constants for messages:
                Const rgxPROC_NAME = "rgxValidate"
                Const rgxERRMSG_CREATE = "Could not create VBScript.RegExp object: "
                Const rgxERRMSG_UNEXPECTED = "Unexpected error: "
 
                'VBScript.Regexp error messages:
                Const rgxERRMSG_5017 = "Syntax error in regular expression"
                Const rgxERRMSG_5019 = "Expected ']' in regular expression"
                Const rgxERRMSG_5020 = "Expected ')' in regular expression"
 
                Dim oRE As Object
 
                On Error GoTo ERRHANDLER
 
                rgxValidate = False 'Set default return value
 
                If IsNull(Target) Then Exit Function
 
                Set oRE = CreateObject("VBScript.RegExp")
 
                'If we're here, the object has been created
                oRE.Global = False
                'oRE.Global = True
                oRE.IgnoreCase = Not CaseSensitive
                oRE.MultiLine = False
 
                If MatchWholeString Then
 
                'Add anchors at ends of Pattern
                '(doesn't matter if Pattern already has them)
 
                    oRE.pattern = "^" & pattern & "$"
                Else
                    oRE.pattern = pattern
 
                End If
 
                'Do it!
                rgxValidate = oRE.test(CStr(Target))
 
                'If we're here, the match executed OK. Normal termination
                Set oRE = Nothing
 
                Exit Function
 
 
 
ERRHANDLER:
                If FailOnError Then
                    With Err
                    Select Case .Number
                        Case 5017: .Description = rgxERRMSG_5017
                        Case 5019: .Description = rgxERRMSG_5019
                        Case 5020: .Description = rgxERRMSG_5020
                    Case Else
                        If oRE Is Nothing Then
                        .Description = rgxERRMSG_CREATE & Err.Description
                        Else
                        .Description = rgxERRMSG_UNEXPECTED & Err.Description
                        End If
                    End Select
 
                    Set oRE = Nothing
                    Err.Raise Err.Number, , rgxPROC_NAME & "(): " & .Description
                    End With
                    Else 'Fail silently
                    Err.Clear
                    Set oRE = Nothing
                End If
 
End Function
 
 
 
'Some useful regular expressions:                
 
                'Notes:
                'Each of these regular expressions is wrapped in a (?: )
                'grouping pattern. This means that they can be OR'd by
                'concatenating them with the pipe character "|". Thus
                ' rgxZIP_US & "|" & rgxZIP_CA
                'will match either US or Canadian postal codes.
                '
                'Official formatting of postcodes and the like may change
                'over time. Some of these expressions may need adjustment
                ' to bring them up to date.                
 
                'UK Postcode
                Public Const rgxZIP_UK = "(?:(?:A[BL]|B[ABDHLNRST]?|" _
                & "C[ABFHMORTVW]|D[ADEGHLNTY]|E[CHNX]?|F[KY]|G[LUY]?|" _
                & "H[ADGPRSUX]|I[GMPV]|JE|K[ATWY]|L[ADELNSU]?|M[EKL]?|" _
                & "N[EGNPRW]?|O[LX]|P[AEHLOR]|R[GHM]|S[AEGKLMNOPRSTWY]?|" _
                & "T[ADFNQRSW]|UB|W[ACDFNRSV]?|YO|ZE)" _
                & "\d(?:\d|[A-Z])? \d[A-Z]{2})"
 
                'A simpler expression that does not check for valid postcode 
                areas:
                ' "(?:[A-Z]{1,2}\d(?:\d|[A-Z])? \d[A-Z]{2})"
 
 
                'Zip or Zip+4
                Public Const rgxZIP_US = "(?:\d{5}(?:-\d{4})?)"                
 
                'Canadian postal codes
                Public Const rgxZip_CA = "(?:[A-Z]\d[A-Z] \d[A-Z]\d)"
 
 
                'Most European postal codes:
                Public Const rgxZIP_EU = "(?:NL-\d{4}(?: [A-Z][A-Z])|" _
                & "(?:IS|FO)\d{3}|" _
                & "(?:A|B|CH|CY|DK|EE|H|L|LT|LV|N)-\d{4}|" _
                & "(?:BA|DE?|E|FR?|FIN?|HR|I|SI|YU)-\d{5}|" _
                & "(?:CZ|GR|S|SK)-\d{3} \d{2}|PL-\d\d-\d{3}|" _
                & "PT-\d{4}(?:-\d{3})?" _
                & ")"                
 
                'A simpler expression that doesn't check the postcode
                'format against the country code
                ' "(?:NL[- ]\d{4} [A-Z][A-Z]|" _
                ' & "(?:[A-Z]{1,2}[- ])?\d{2,3}(?:\d\d?| \d\d|\d-\d{3}))"                
 
                'US States
                Public Const rgxSTATES_US = "(:?A[KLRZ]|C[AOT]|D[CE]|FL|" _
                & "GA|HI|I[ADLN]|K[SY]|LA|M[ADEINOST]|N[CDEHJMVY]|" _
                & "O[HKR]|P[AR]|RI|S[CD]|T[NX]|" _
                & "UT|V[AIT]|W[AIVY])"                
 
                'Australian States
                Public Const rgxSTATES_AU = "(?:ACT|NSW|NT|QLD|SA|TAS|VIC|WA)"                
 
                'Canadian Provinces
                Public Const rgxPROVINCES_CA = "(?:AB|BC|MB|N[BLTSU]|ON|PE|QC|SK|YT)"           
 
                'Canonical phone number
                Public Const rgxPHONE_INTL = "(?:\+\d{1,4} ?(?:\(\d{0,5}\))?(?:\d+[-. ])*\d{2,})"