Created
May 15, 2013 08:41
-
-
Save DaveRandom/5582494 to your computer and use it in GitHub Desktop.
VB classic regular expressions that suck (a bit) less
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
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 |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
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 |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
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 |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
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 | |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment