Função InStr suportando expressões regulares

Depois de ler este artigo
usandoaccess.com.br/tutoriais/expressoes-regulares-microsoft-access.asp?id=1

E ler este divertido livro online
aurelio.net/regex/guia/

Resolvi dar um "upgrade" na função InStr.

Veja

Código:

Public Function fncInStr(ByVal strTexto As String, _
                        ByVal strExpressao As String, _
                        Optional ByVal booUsaExpressaoRegular As Boolean = False, _
                        Optional ByVal booReverso As Boolean = False, _
                        Optional ByVal booCaseSensitive As Boolean = True, _
                        Optional ByVal intPosOndeComeca As Integer = 0) _
                        As Integer
' ----------------------------------------------------------------
' Autor    : DamascenoJr. (contato@damascenojr.com.br)
' Data      : 13/10/2020
' Propósito : Retornar a posição de um trecho de texto que atenda a uma expressão.
' ----------------------------------------------------------------

    If Not booUsaExpressaoRegular Then
        If booReverso Then
            fncInStr = InStrRev(strTexto, strExpressao, IIf(intPosOndeComeca = 0, -1, intPosOndeComeca), IIf(booCaseSensitive, vbBinaryCompare, vbTextCompare))
        Else
            fncInStr = InStr(IIf(intPosOndeComeca = 0, 1, intPosOndeComeca), strTexto, strExpressao, IIf(booCaseSensitive, vbBinaryCompare, vbTextCompare))
        End If
        Exit Function
    End If
   
    Const LETRAS_MAIUSCULAS_COM_ACENTO As String = "ÁÍÓÚÉÄÏÖÜËÀÌÒÙÈÃÕÂÎÔÛÊÇÑ"
    Const LETRAS_MINUSCULAS_COM_ACENTO As String = "áíóúéäïöüëàìòùèãõâîôûêçñ"

    Dim objRegEx            As Object
    Dim objMatchCollection  As Object
   
    strExpressao = Replace(strExpressao, "[:upper:]", "A-Z" & LETRAS_MAIUSCULAS_COM_ACENTO)
    strExpressao = Replace(strExpressao, "[:lower:]", "a-z" & LETRAS_MINUSCULAS_COM_ACENTO)
    strExpressao = Replace(strExpressao, "[:alpha:]", "A-Za-z" & LETRAS_MAIUSCULAS_COM_ACENTO & LETRAS_MINUSCULAS_COM_ACENTO)
    strExpressao = Replace(strExpressao, "[:alnum:]", "A-Za-z0-9" & LETRAS_MAIUSCULAS_COM_ACENTO & LETRAS_MINUSCULAS_COM_ACENTO)
    strExpressao = Replace(strExpressao, "[:digit:]", "0-9")
    strExpressao = Replace(strExpressao, "[:xdigit:]", "A-Fa-f0-9")
    strExpressao = Replace(strExpressao, "[:punct:]", ".,!?:...")
    strExpressao = Replace(strExpressao, "[:blank:]", " \t")
    strExpressao = Replace(strExpressao, "[:space:]", " \t\n\r\f\v")
    strExpressao = Replace(strExpressao, "[:graph:]", "^ \t\n\r\f\v")
    strExpressao = Replace(strExpressao, "[:print:]", "^\t\n\r\f\v")

    Set objRegEx = CreateObject("VbScript.RegExp")
   
    With objRegEx
   
        .Global = True
        .IgnoreCase = Not booCaseSensitive
        .Pattern = strExpressao
       
        If booReverso And (intPosOndeComeca > 0) Then
            strTexto = Left(strTexto, intPosOndeComeca)
        Else
            If intPosOndeComeca = 0 Then intPosOndeComeca = 1
            strTexto = Mid(strTexto, intPosOndeComeca)
        End If
       
        Set objMatchCollection = .Execute(strTexto)
        With objMatchCollection
            If .Count > 0 Then
                If booReverso Then
                    fncInStr = InStrRev(strTexto, .Item(.Count - 1), -1, IIf(booCaseSensitive, vbBinaryCompare, vbTextCompare))
                Else
                    fncInStr = InStr(1, strTexto, .Item(0), IIf(booCaseSensitive, vbBinaryCompare, vbTextCompare))
                End If
            End If
        End With
        Set objMatchCollection = Nothing
       
    End With
   
    Set objRegEx = Nothing
   
End Function

Rapaz, cada vez melhores seus exemplos! Parabéns e grato por compartilhar!

Obrigado, Marcelo.

Olá a todos,

ParabénsDamasceno, excelente "upgrade".

Valeu, Alvaro

Muito bom