Regular Expression

Posted on 1998-12-22
Last Modified: 2010-05-03
Can anyone point me to a resource that may have a *free* MODULE or code for regular expression pattern matching? (a la perl--With substrings, etc.)  I don't want to use a .dll or .ocx.
Question by:IsleOfView
  • 2
LVL 13

Expert Comment

ID: 1451977
This one is not free, but it is good.
LVL 13

Accepted Solution

Mirkwood earned 100 total points
ID: 1451978

' Name: RegularExpression
' Description:This is a class module that performs
'      regular expression searches in a string.
' By: visual basic prof. edition
' Inputs:Use the Init method to initialize to a specific regular expression (which will be precompiled), then use Match to check if a string contains such a substring.
' Returns:None
' Assumes:a) Put this code in a new .CLS file (NOT in a class module).
b) The syntax for range (e.g. [a-z]) is the same as for operator Like.
c) Not calling Init, or passing an empty pattern, will result in an "Illegal function call" error.
' Side Effects:None
'Code provided by Planet Source Code(tm) 'as is', without
'     warranties as to performance, fitness, merchantability,
'     and any other warranty (whether expressed or implied).

 MultiUse = -1 'True

Attribute VB_Name = "RegularExpression"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
'     'PRIVATE
'? = edOptional; + = edMulti; * = edOptional or ed
'     Multi
Private Enum RegExpStateTypes
edOptional = 65536
edMulti = 131072
edModifierMask = edOptional Or edMulti
edCharacter = 0
edBracketed = 262144'for example, [a-z]
edAny = 524288
End Enum

Private Type StateStack
    State As Long
    Posi As Long
    MinPosi As Long
End Type

    Private mStack() As StateStack
    Private mCompiled() As Long
    Private mNStates As Long
    Private mPattern As String
    Private mAnchorBeginning As Boolean
    Private mAnchorEnd As Boolean
    Private mMinLength As Long

Private Sub AddState(ByVal Flags As Long, ByVal CharOrPosi As Long)

    If mNStates = UBound(mCompiled) Then
        ReDim Preserve mCompiled(1 To mNStates + 10) As Long
    End If

        mNStates = mNStates + 1
        mCompiled(mNStates) = CharOrPosi Or Flags
End Sub

Public Sub Init(RegExp As String)

    Dim StackSize As Long, Posi As Long, EndPosi As Long
    '     'Initialize member variables
    mPattern = RegExp
    mNStates = 0
    mMinLength = 0
    ReDim mCompiled(1 To 10) As Long
    Posi = 1
EndPosi = Len(RegExp)

    If Left(mPattern, 1) = "^" Then
        Posi = Posi + 1
        mAnchorBeginning = True
    End If

        If Right(mPattern, 1) = "$" And Right(mPattern, 2) <> "\$" Then
        EndPosi = EndPosi - 1

            mAnchorEnd = True
        End If

            Do Until Posi > EndPosi
                Select Case Mid$(mPattern, Posi, 1)
                Case "."
                AddState edAny, 0
                Posi = Posi + 1
                Case "\"
                AddState edCharacter, Asc(Mid$(mPattern, Posi + 1, 1))
                Posi = Posi + 2
                Case "["
                AddState edBracketed, Posi
                Posi = RangeParse(Posi)

                If Posi = -1 Then Err.Raise 5
                    Case Else
                    AddState edCharacter, Asc(Mid$(mPattern, Posi, 1))
                    Posi = Posi + 1
                End Select

                    '     'check for modifiers (?, +, *)
                    Select Case Mid$(mPattern, Posi, 1)
                    Case "?"
                    mCompiled(mNStates) = mCompiled(mNStates) Or edOptional
                    StackSize = StackSize + 1
                    Posi = Posi + 1
                    Case "+"
                    mCompiled(mNStates) = mCompiled(mNStates) Or edMulti
                    StackSize = StackSize + 1
                    Posi = Posi + 1
                    mMinLength = mMinLength + 1
                    Case "*"
                    mCompiled(mNStates) = mCompiled(mNStates) Or edMulti Or edOptional
                    StackSize = StackSize + 1
                    Posi = Posi + 1
                    Case Else
                    mMinLength = mMinLength + 1
                End Select


                    'Minimize wasted memory by dimensioning exact arra
                    '     ys
                    ReDim Preserve mCompiled(1 To mNStates) As Long
                    ReDim mStack(1 To StackSize) As StateStack
            End Sub

Public Function Match(ByRef FromX As Long, ByRef ToX As Long, Text As String) As Boolean

    Dim Match As Boolean
    Dim CurState As Long
    Dim State As Long
    Dim SP As Long
    Dim LenText As Long

    If mNStates = 0 Then Err.Raise 5
        LenText = Len(Text)

        For FromX = FromX To IIf(mAnchorBeginning, 1, LenText - mMinLength)
            ToX = FromX
            State = 1
            SP = 0


                If State > mNStates Then

                    If (Not mAnchorEnd) Or (ToX > LenText) Then
                        'ToX is pointing the first character PAST the matc
                        '     hed string
                        ToX = ToX - 1
                        MatchRight = True
                        Exit Function
                    End If

                    End If

                        GoSub MatchState

                        If Match Then

                            If CurState And edModifierMask Then
                                '     'create a new item in the backtrack stack
                                SP = SP + 1
                                mStack(SP).MinPosi = IIf(CurState And edOptional, ToX, ToX + 1)
                                If (CurState And (edAny Or edMulti)) = (edAny Or edMulti) Then
                                    'When matching .* and .+, we don't need to check t
                                    '     he whole string
                                    ToX = LenText + 1
                                ElseIf CurState And edMulti Then
                                    '     '+ or *, try to get as far as possible

                                        ToX = ToX + 1
                                        GoSub MatchState
                                    Loop Until Not Match

                                        '     '?, you only have to look one character ahead
                                        ToX = ToX + 1
                                    End If

                                        State = State + 1
                                        mStack(SP).Posi = ToX
                                        mStack(SP).State = State
                                        '     'no +, *, nor ?, just advance to the next state
                                        ToX = ToX + 1
                                        State = State + 1
                                    End If

                                    ElseIf CurState And edOptional Then
                                        '     'not matched, but it was optional... no problem
                                        State = State + 1
                                        'backtrack - find the next usable item in the stac
                                        '     k

                                        For SP = SP To 1 Step -1

                                            If mStack(SP).Posi > mStack(SP).MinPosi Then Exit For
                                            Next SP

                                                If SP = 0 Then Exit Do
                                                    mStack(SP).Posi = mStack(SP).Posi - 1
                                                    ToX = mStack(SP).Posi
                                                    State = mStack(SP).State
                                                End If


                                                Next FromX

                                                    Exit Function
                                                    CurState = mCompiled(State)

                                                    If ToX > LenText Then
                                                        Match = False
                                                    ElseIf CurState And edAny Then
                                                        Match = True
                                                    ElseIf CurState And edBracketed Then
                                                        Match = RangeMatch(CurState And 65535, Mid$(Text, ToX, 1))
                                                        Match = (CurState And 65535) = Asc(Mid$(Text, ToX, 1))
                                                    End If

                                                    End Function

Private Function RangeMatch(Posi As Long, ch As String) As Boolean

    RangeMatch = ch Like Mid$(mPattern, Posi, InStr(Posi, mPattern, "]") - Posi + 1)
End Function

    'Return the end of the range (e.g. [a-z]) starting
    '      at position Posi.
    'Return -1 if the regular expression is not well f
    '     ormed.

Private Function RangeParse(Posi As Long) As Long

    Dim EndPosi As Long
EndPosi = InStr(Posi, mPattern, "]")

    'Try using operator Like and check if an error occ
    '     urs
    On Error Resume Next

    If "a" Like Mid(mPattern, Posi, EndPosi - Posi + 1) Then:

        If Err Then
            RangeParse = -1
            RangeParse = EndPosi + 1
        End If

        End Function


Featured Post

Free Tool: IP Lookup

Get more info about an IP address or domain name, such as organization, abuse contacts and geolocation.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Have you ever wanted to restrict the users input in a textbox to numbers, and while doing that make sure that they can't 'cheat' by pasting in non-numeric text? Of course you can do that with code you write yourself but it's tedious and error-prone …
I was working on a PowerPoint add-in the other day and a client asked me "can you implement a feature which processes a chart when it's pasted into a slide from another deck?". It got me wondering how to hook into built-in ribbon events in Office.
As developers, we are not limited to the functions provided by the VBA language. In addition, we can call the functions that are part of the Windows operating system. These functions are part of the Windows API (Application Programming Interface). U…
This lesson covers basic error handling code in Microsoft Excel using VBA. This is the first lesson in a 3-part series that uses code to loop through an Excel spreadsheet in VBA and then fix errors, taking advantage of error handling code. This l…

733 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question