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,})"