VB classic regular expressions that suck (a bit) less

RegExp.bas

Attribute VB_Name = "RegExp"
Option Compare Database
Option Explicit

Public Enum REGEXP_PARSEERROR
    REGEXP_PARSEERROR_INVALIDWRAPPER = 1
    REGEXP_PARSEERROR_UNBALANCEDESCAPES = 2
    REGEXP_PARSEERROR_UNKNOWNMODIFIER = 3
    REGEXP_PARSEERROR_SYNTAXERROR = 4
    REGEXP_PARSEERROR_UNEXPECTEDQUANTIFIER = 5
    REGEXP_PARSEERROR_UNCLOSEDCHARACTERCLASS = 6
    REGEXP_PARSEERROR_UNCLOSEDGROUP = 7
    REGEXP_PARSEERROR_INVALIDRANGEINCHARACTERCLASS = 8
End Enum

Public Enum REGEXP_FLAGS
    REGEXP_SPLIT_NO_EMPTY = 1
    REGEXP_SPLIT_DELIM_CAPTURE = 2
    REGEXP_GREP_INVERT = 4
End Enum

Public Function Create(ByVal Pattern As String) As RegExpPattern

    Dim objExpr As Object, _
        objMatch As Object, _
        strPattern As String, _
        strModifiers As String, _
        boolMatch As Boolean, _
        intCounter As Integer, _
        boolIgnoreCase As Boolean

    Set objExpr = CreateObject("vbscript.regexp")
    objExpr.Pattern = "^/(.+?)/([a-z]*)$"
    Set objMatch = objExpr.Execute(Pattern)
    Set objExpr = Nothing

    If objMatch.Count = 0 Then
        Set objMatch = Nothing
        Err.Raise REGEXP_PARSEERROR_INVALIDWRAPPER, "RegExp.Create", "Bad pattern (invalid wrapper): " & Pattern
    End If
    strPattern = objMatch(0).SubMatches(0)
    strModifiers = objMatch(0).SubMatches(1)
    Set objMatch = Nothing

    Set objExpr = CreateObject("vbscript.regexp")
    objExpr.Pattern = "^(?:[^\\/]|\\.)+$"
    boolMatch = objExpr.Test(strPattern)
    Set objExpr = Nothing

    If Not boolMatch Then
        Err.Raise REGEXP_PARSEERROR_UNBALANCEDESCAPES, "RegExp.Create", "Bad pattern (unbalanced escapes): " & Pattern
    End If
    strPattern = Replace(strPattern, "\/", "/")

    boolIgnoreCase = False
    For intCounter = 1 To Len(strModifiers)
        Select Case Mid(strModifiers, intCounter, 1)
            Case "i"
                boolIgnoreCase = True
            Case Else
                Err.Raise REGEXP_PARSEERROR_UNKNOWNMODIFIER, "RegExp.Create", "Bad pattern (unknown modifier '" & Mid(strModifiers, intCounter, 1) & "'): " & Pattern
        End Select
    Next intCounter

    Set objExpr = CreateObject("vbscript.regexp")
    objExpr.Pattern = strPattern
    objExpr.IgnoreCase = boolIgnoreCase

    On Error GoTo Err_Create_TestParse
    objExpr.Test "test"
    On Error GoTo 0
    GoTo Create_CreatePattern

Err_Create_TestParse:
    Set objExpr = Nothing
    Select Case Err.Number
        Case 5017
            Err.Raise REGEXP_PARSEERROR_SYNTAXERROR, "RegExp.Create", "Bad pattern (syntax error): " & Pattern
        Case 5018
            Err.Raise REGEXP_PARSEERROR_UNEXPECTEDQUANTIFIER, "RegExp.Create", "Bad pattern (unexpected quantifier): " & Pattern
        Case 5019
            Err.Raise REGEXP_PARSEERROR_UNCLOSEDCHARACTERCLASS, "RegExp.Create", "Bad pattern (unclosed character class): " & Pattern
        Case 5020
            Err.Raise REGEXP_PARSEERROR_UNCLOSEDGROUP, "RegExp.Create", "Bad pattern (unclosed group): " & Pattern
        Case 5021
            Err.Raise REGEXP_PARSEERROR_INVALIDRANGEINCHARACTERCLASS, "RegExp.Create", "Bad pattern (invalid range in character class): " & Pattern
        Case Else
            Err.Raise Err.Number, Err.Source, Err.Description
    End Select

Create_CreatePattern:
    Set Create = New RegExpPattern
    Create.Pattern = Pattern
    Set Create.RegExp = objExpr

End Function

Public Function Quote(ByVal Subject As String) As String

    Quote = RegExp.Create("/([.+*?[$(){}=!<>|:\\\/\^\]\-])/").Replace(Subject, "\$1")

End Function

RegExpMatch.bas

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "RegExpMatch"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Compare Database
Option Explicit

Private objMatch As Object


''''''''''''''''''''''''''''''''''
'     Constructor/Destructor     '
''''''''''''''''''''''''''''''''''

' Constructor
Private Sub Class_Initialize()

End Sub

' Destructor
Private Sub Class_Terminate()

    Set objMatch = Nothing

End Sub


'''''''''''''''''''''''''''''
'     Public Properties     '
'''''''''''''''''''''''''''''

Public Property Get FirstIndex() As Long

    If objMatch Is Nothing Then Err.Raise 1, "RegExpMatch.FirstIndex", "Cannot access properties of an uninitialized object, use a RegExpPattern match or replace method"

    FirstIndex = CLng(objMatch.FirstIndex)

End Property

Public Property Get Length() As Long

    If objMatch Is Nothing Then Err.Raise 1, "RegExpMatch.Length", "Cannot access properties of an uninitialized object, use a RegExpPattern match or replace method"

    Length = CLng(objMatch.Length)

End Property

Public Property Get Value() As String

    If objMatch Is Nothing Then Err.Raise 1, "RegExpMatch.Value", "Cannot access properties of an uninitialized object, use a RegExpPattern match or replace method"

    Value = objMatch.Value

End Property

Public Property Get Match() As Object

    If objMatch Is Nothing Then Err.Raise 1, "RegExpMatch.Match", "Cannot access properties of an uninitialized object, use a RegExpPattern match or replace method"

    Set Match = objMatch

End Property

Public Property Set Match(ByRef objMtch As Object)

    If Not objMatch Is Nothing Then Err.Raise 1, "RegExpMatch.Match", "Cannot re-initialize object, use a RegExpPattern match or replace method"

    Set objMatch = objMtch

End Property

Public Property Get Item(intIndex As Integer) As String
Attribute Item.VB_UserMemId = 0

    If objMatch Is Nothing Then Err.Raise 1, "RegExpMatch.Item", "Cannot access properties of an uninitialized object, use a RegExpPattern match or replace method"

    If intIndex > objMatch.SubMatches.Count Then Err.Raise 1, "RegExpMatch.Item", "Invalid capture group index " & intIndex

    If intIndex > 0 Then
        Item = objMatch.SubMatches(intIndex - 1)
    Else
        Item = objMatch.Value
    End If

End Property

RegExpMatchCollection.bas

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "RegExpMatchCollection"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Compare Database
Option Explicit

Private objMatches As Collection

''''''''''''''''''''''''''''''''''
'     Constructor/Destructor     '
''''''''''''''''''''''''''''''''''

' Constructor
Private Sub Class_Initialize()

End Sub

' Destructor
Private Sub Class_Terminate()

    Set objMatches = Nothing

End Sub


'''''''''''''''''''''''''''''
'     Public Properties     '
'''''''''''''''''''''''''''''

Public Property Get Matches() As Object

    If objMatches Is Nothing Then Err.Raise 1, "RegExpMatchCollection.Matches", "Cannot access properties of an uninitialized object, use the RegExpPattern.MatchAll method"

    Set Matches = objMatches

End Property

Public Property Set Matches(ByRef objMatchCollection As Object)

    If Not objMatches Is Nothing Then Err.Raise 1, "RegExpMatchCollection.Matches", "Cannot re-initialize object, use the RegExpPattern.MatchAll method"

    Dim varMatch As Object, _
        objMatch As RegExpMatch

    Set objMatches = New Collection
    For Each varMatch In objMatchCollection
        Set objMatch = New RegExpMatch
        Set objMatch.Match = varMatch
        objMatches.Add objMatch
    Next varMatch

End Property

Public Property Get NewEnum() As IUnknown
Attribute NewEnum.VB_UserMemId = -4
Attribute NewEnum.VB_MemberFlags = "40"

    If objMatches Is Nothing Then Err.Raise 1, "RegExpMatchCollection.NewEnum", "Cannot access properties of an uninitialized object, use the RegExpPattern.MatchAll method"

    Set NewEnum = objMatches.[_NewEnum]

End Property


Public Property Get Count() As Long

    If objMatches Is Nothing Then Err.Raise 1, "RegExpMatchCollection.Count", "Cannot access properties of an uninitialized object, use the RegExpPattern.MatchAll method"

    Count = CLng(objMatches.Count)

End Property

Public Property Get Item(intIndex As Integer) As RegExpMatch
Attribute Item.VB_UserMemId = 0

    If objMatches Is Nothing Then Err.Raise 1, "RegExpMatchCollection.Item", "Cannot access properties of an uninitialized object, use the RegExpPattern.MatchAll method"

    Set Item = objMatches.Item(intIndex + 1)

End Property

RegExpPattern.bas

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "RegExpPattern"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Compare Database
Option Explicit

Private objPattern As Object
Private strPattern As String


''''''''''''''''''''''''''''''''''
'     Constructor/Destructor     '
''''''''''''''''''''''''''''''''''

' Constructor
Private Sub Class_Initialize()

End Sub

' Destructor
Private Sub Class_Terminate()

    Set objPattern = Nothing

End Sub


'''''''''''''''''''''''''''''
'     Public Properties     '
'''''''''''''''''''''''''''''

Public Property Get Pattern() As String
Attribute Pattern.VB_UserMemId = 0

    If objPattern Is Nothing Then Err.Raise 1, "RegExpPattern.Pattern", "Cannot access properties of an uninitialized object, use the RegExp.Create factory method"

    Pattern = strPattern

End Property

Public Property Let Pattern(ByVal strRegExp As String)

    If Not objPattern Is Nothing Then Err.Raise 1, "RegExpPattern.Pattern", "Cannot re-initialize object, use the RegExp.Create factory method"

    strPattern = strRegExp

End Property

Public Property Get RegExp() As Object

    If objPattern Is Nothing Then Err.Raise 1, "RegExpPattern.RegExp", "Cannot access properties of an uninitialized object, use the RegExp.Create factory method"

    Set RegExp = objPattern

End Property

Public Property Set RegExp(ByRef objRegExp As Object)

    If Not objPattern Is Nothing Then Err.Raise 1, "RegExpPattern.RegExp", "Cannot re-initialize object, use the RegExp.Create factory method"

    Set objPattern = objRegExp

End Property



''''''''''''''''''''''''''''
'      Public Methods      '
''''''''''''''''''''''''''''

Public Function Grep(ByRef Subject() As String, ByRef Flags As Integer) As String()

    Dim arrResult() As String, _
        intLength As Long, _
        varElement As Variant, _
        boolInvert As Boolean, _
        boolMatch As Boolean

    If objPattern Is Nothing Then Err.Raise 1, "RegExpPattern.Grep", "Cannot call methods of an uninitialized object, use the RegExp.Create factory method"

    intLength = 0
    boolInvert = CBool(Flags And REGEXP_GREP_INVERT)

    For Each varElement In Subject
        boolMatch = Me.Test(varElement)
        If (boolMatch And Not boolInvert) Or (Not boolMatch And boolInvert) Then
            ReDim Preserve arrResult(0 To intLength)
            arrResult(intLength) = CStr(varElement)
            intLength = intLength + 1
        End If
    Next varElement

    Grep = arrResult

End Function

Public Function Match(ByVal Subject As String, Optional ByRef Matched As RegExpMatch) As Byte

    If objPattern Is Nothing Then Err.Raise 1, "RegExpPattern.Match", "Cannot call methods of an uninitialized object, use the RegExp.Create factory method"

    Dim objMatches As Object

    objPattern.Global = False
    Match = 0

    Set objMatches = objPattern.Execute(Subject)
    If objMatches.Count = 0 Then Exit Function

    Match = 1
    Set Matched = New RegExpMatch
    Set Matched.Match = objMatches(0)

End Function

Public Function MatchAll(ByVal Subject As String, Optional ByRef Matches As RegExpMatchCollection) As Byte

    If objPattern Is Nothing Then Err.Raise 1, "RegExpPattern.MatchAll", "Cannot call methods of an uninitialized object, use the RegExp.Create factory method"

    Dim objMatches As Object

    objPattern.Global = True
    MatchAll = 0

    Set objMatches = objPattern.Execute(Subject)
    If objMatches.Count = 0 Then Exit Function

    MatchAll = objMatches.Count
    Set Matches = New RegExpMatchCollection

    Set Matches.Matches = objMatches

End Function

Public Function Replace(ByVal Subject As String, ByVal Replacement As String, Optional ByVal Limit As Long = -1, Optional ByRef Count As Long) As String

    Dim objMatches As RegExpMatchCollection, _
        objMatch As RegExpMatch, _
        objReplacePattern As Object, _
        intPos As Long, _
        strBefore As String, _
        strReplaced As String, _
        strReplacement As String, _
        strSubject As String

    If objPattern Is Nothing Then Err.Raise 1, "RegExpPattern.Replace", "Cannot call methods of an uninitialized object, use the RegExp.Create factory method"

    Replace = Subject
    Count = 0
    
    If Me.MatchAll(Subject, objMatches) < 1 Then Exit Function

    Set objReplacePattern = CreateObject("vbscript.regexp")
    objReplacePattern.Pattern = objPattern.Pattern
    objReplacePattern.IgnoreCase = objPattern.IgnoreCase
    objReplacePattern.Global = False

    intPos = 0
    Replace = ""

    For Each objMatch In objMatches
        If Limit > -1 And Count = Limit Then Exit For

        strBefore = Mid(Subject, intPos + 1, objMatch.FirstIndex - intPos)

        strSubject = Mid(Subject, intPos + Len(strBefore) + 1)
        strReplaced = objReplacePattern.Replace(strSubject, Replacement)
        strReplacement = Mid(strReplaced, 1, objMatch.Length + (Len(strReplaced) - Len(strSubject)))

        Replace = Replace & strBefore & strReplacement
        intPos = objMatch.FirstIndex + objMatch.Length
        Count = Count + 1
    Next objMatch

    Set objMatch = Nothing
    Set objMatches = Nothing
    Set objReplacePattern = Nothing

    Replace = Replace & Mid(Subject, intPos + 1)

End Function

Public Function ReplaceCallback(ByVal Subject As String, ByRef Obj As Object, ByVal FuncName As String, Optional ByVal Limit As Long = -1, Optional ByRef Count As Long) As String

    Dim objMatches As RegExpMatchCollection, _
        objMatch As RegExpMatch, _
        intPos As Long, _
        strBefore As String, _
        strReplacement As String

    If objPattern Is Nothing Then Err.Raise 1, "RegExpPattern.ReplaceCallback", "Cannot call methods of an uninitialized object, use the RegExp.Create factory method"

    ReplaceCallback = Subject
    Count = 0

    If Me.MatchAll(Subject, objMatches) < 1 Then Exit Function

    intPos = 0
    ReplaceCallback = ""

    For Each objMatch In objMatches
        If Limit > -1 And Count = Limit Then Exit For

        strBefore = Mid(Subject, intPos + 1, objMatch.FirstIndex - intPos)
        On Error GoTo Err_ReplaceCallback_CallbackError
        strReplacement = CallByName(Obj, FuncName, VbMethod, objMatch)
        On Error GoTo 0

        ReplaceCallback = ReplaceCallback & strBefore & strReplacement
        intPos = objMatch.FirstIndex + objMatch.Length
        Count = Count + 1
    Next objMatch

    Set objMatch = Nothing
    Set objMatches = Nothing

    ReplaceCallback = ReplaceCallback & Mid(Subject, intPos + 1)

Exit Function
Err_ReplaceCallback_CallbackError: Err.Raise 1, "RegExpPattern.ReplaceCallback", "An error occurred in the callback function: " & Err.Source & " raise error " & Err.Number & ": " & Err.Description
End Function

Public Function Split(ByVal Subject As String, Optional ByVal Limit As Long = -1, Optional ByVal Flags As Integer = 0) As String()

    Dim objMatches As RegExpMatchCollection, _
        objMatch As RegExpMatch, _
        arrResult() As String, _
        intPos As Long, _
        intLength As Long, _
        intCount As Long, _
        boolDelimCapture As Boolean, _
        boolNoEmpty As Boolean, _
        strBefore As String

    If objPattern Is Nothing Then Err.Raise 1, "RegExpPattern.Split", "Cannot call methods of an uninitialized object, use the RegExp.Create factory method"

    Me.MatchAll Subject, objMatches

    intPos = 0
    intLength = 0
    intCount = 1
    boolDelimCapture = CBool(Flags And REGEXP_SPLIT_DELIM_CAPTURE)
    boolNoEmpty = CBool(Flags And REGEXP_SPLIT_NO_EMPTY)

    For Each objMatch In objMatches
        If Limit > -1 And intCount = Limit Then Exit For

        strBefore = Mid(Subject, intPos + 1, objMatch.FirstIndex - intPos)
        If Not boolNoEmpty Or Len(strBefore) > 0 Then
            ReDim Preserve arrResult(0 To intLength)
            arrResult(intLength) = strBefore
            intLength = intLength + 1
        End If

        If boolDelimCapture And (Not boolNoEmpty Or objMatch.Length > 0) Then
            ReDim Preserve arrResult(0 To intLength)
            arrResult(intLength) = objMatch(0)
            intLength = intLength + 1
        End If

        intPos = objMatch.FirstIndex + objMatch.Length
        intCount = intCount + 1
    Next objMatch

    Set objMatch = Nothing
    Set objMatches = Nothing

    ReDim Preserve arrResult(0 To intLength)
    arrResult(intLength) = Mid(Subject, intPos + 1)

    Split = arrResult

End Function

Public Function Test(ByVal Subject As String) As Boolean

    If objPattern Is Nothing Then Err.Raise 1, "RegExpPattern.Test", "Cannot call methods of an uninitialized object, use the RegExp.Create factory method"

    Test = objPattern.Test(Subject)

End Function