É sempre importante termos algumas funções que fazem truques novos para analisarmos os nossos dados.
Muitas vezes é necessário extrairmos um único bloco de dados a partir de um campo de texto ou outra string. O padrão VBA de manipulação funções como InStr () e Mid () podem nos ajudar muitas vezes, mas exigem uma codificação trabalhosa quando se trata de identificar e extrair parte de uma string que corresponde a um determinado padrão - por exemplo, um CEP ( cinco dígitos e, opcionalmente, um hífen e mais quatro dígitos) ou um código postal do Reino Unido (por exemplo, "B1 3AA", "SA21 4FH", "SW1P 5RH").
A função rgxExtract() pode ser usada no VBA de toda a suíte do MS Office, e em consultas num banco de dados MS Access.
Argumentos
rgxExtract() leva até seis argumentos, embora normalmente só os dois primeiros ou três são necessários. Estes são como se segue:Target As VariantTarget é a string a ser procurada. Ela é declarada como uma Variant para torná-la mais fácil de usar nas consultas de acesso: se Target for nulo, a função simplesmente retornrá Null.Pattern As StringPattern é a expressão regular para ser usada. Mesmo se declarada como opcional, você deve sempre passar o padrão.Item As LongItem é um argumento opcional para uso quando a expressão regular for produzir mais do que um jogo, ou quando houver agrupamento / captura parênteses no padrão.Se o Item for omitido, a função retorna o primeiro (ou único) corresponde encontrado.Se Item >= 0 , a função retorna a partida correspondente. 0 retorna o primeiro jogo, 1 o segundo, e assim por diante. Se Item exceder o número de partidas, a função retorna um erro de intervalo (ou nulo se você tiver especificado que não deve falhar em erros (veja abaixo).Os argumentos restantes são opcionais e são menos frequentemente necessário. Eles são:CaseSensitive As BooleanPor padrão, rgxExtract não é case-sensitive (combinando o comportamento padrão para buscas do Access). Definir CaseSensitive como True muda isso.FailOnError As BooleanPor padrão, é definido como True , e qualquer erro em tempo de execução será passado de volta para a rotina de chamada com uma mensagem apropriada. Isto é conveniente para depuração, mas pode ser um grande incômodo quando você está chamando rgxExtract() a partir de uma consulta do Access e aparece uma messagebox para relatar um erro - repetindo-se para cada uma das dezenas ou centenas de registros. Se você definir FailOnError para False, RgxExtract() simplesmente ignorará a maioria dos erros (como expressões regulares defeituosas e os Item erros intervalo mencionado acima), retornando Null.Persist as BooleanNormalmente, cada vez que você chamar rgxExtract() precisa criar e inicializar o objeto de expressão regular VBScript que ele usa. Este tempo se torna significativo se a função está sendo chamado dentro de um loop ou de uma consulta que está processando milhares de registros. Se você definir Persist como True , o objeto de expressão regular será criado uma vez e deixado na memória entre as chamadas sucessivas do rgxExtract(). Isso pode acelerar bastante os nossos laços.Se você usar Persist , o objeto de expressão regular vai ficar na memória após a última chamada para rgxExtract(). Você pode eliminá-lo, chamando rgxExtract() mais uma vez sem argumentos.
Public Function rgxExtract (Optional ByVal Target As Variant, _Optional Pattern As String = "", _Optional ByVal Item As Long = 0, _Optional CaseSensitive As Boolean = False, _Optional FailOnError As Boolean = True, _Optional Persist As Boolean = False) _As Variant'Regular expression matching function suitable for use'in VB/A generally and in Access queries.'By John Nurick. Updated 14 Jan 06.'Takes a search string (Target) and a regular expression'(Pattern), and an optional Item argument.'- If Item is omitted and a substring of Target matches Pattern,' returns that substring.'- If Pattern includes grouping parentheses, a substring of Target' matches Pattern, and Item is an integer, returns the submatch' specified by Item (first submatch is item 0). If there aren't' enough submatches, returns Null. Negative values of Item start' counting with the last submatch.'- If no match, returns Null.'- Returns Null on error unless FailOnError is True.' Always matches against the entire Target (i.e. Global and' Multiline are True).'CaseSensitive matches regardless of case.'Persist controls whether the compiled RegExp object'remains in memory ready for the next call to the'function or whether it is disposed of immediately. This'means the function can be used in queries without having'to create, compile, use and destroy a new RegExp object for'each row being processed. But it also means that the object'remains in memory after the query has run. To destroy the'object and release the memory, call this function one'last time with no arguments.''Calling the function with different arguments (e.g. a new'Pattern) recompiles the RegExp object, so'the function can be used in different queries. However there'may be problems if two threads are calling the function at'the same time.Const rgxPROC_NAME = "rgxExtract"Static oRE As Object 'VBScript_RegExp_55.RegExp'Static declaration means we don't have to create'and compile the RegExp object every single time'the function is called.Dim oMatches As Object 'VBScript_RegExp_55.MatchCollectionOn Error GoTo ErrHandlerrgxExtract = Null 'Default return value'NB: if FailOnError is false, returns Null on errorIf IsMissing(Target) Then'This is the signal to dispose of oRESet oRE = NothingExit Function 'with default valueEnd If'Create the RegExp object if necessaryIf oRE Is Nothing ThenSet oRE = CreateObject("VBScript.Regexp")End IfWith oRE'Check whether the current arguments (other than Target)'are different from those stored in oRE, and update them'(thereby recompiling the regex) only if necessary.If CaseSensitive = .IgnoreCase Then.IgnoreCase = Not .IgnoreCaseEnd If.Global = True.Multiline = True' If Multiline <> .Multiline Then' .Multiline = Multiline' End IfIf Pattern <> .Pattern Then.Pattern = PatternEnd If'Finally, execute the matchIf IsNull(Target) ThenrgxExtract = NullElseSet oMatches = oRE.Execute(Target)If oMatches.Count > 0 ThenIf oMatches(0).SubMatches.Count = 0 Then'No ( ) group in Pattern: return the matchIf Item < 0 Then 'we're counting from last item'convert to count from the first itemItem = oMatches.Count + ItemEnd IfSelect Case ItemCase Is < 0'Negative Item originally passed exceeded the'number of matchesrgxExtract = NullIf FailOnError ThenErr.Raise 9End IfCase Is >= oMatches.Count'Positive Item exceeded the number of matchesrgxExtract = NullIf FailOnError ThenErr.Raise 9End IfCase ElsergxExtract = oMatches(Item)End SelectElse 'There are one or more ( ) captured groups in Pattern'return the one specified by ItemWith oMatches(0).SubMatchesIf Item < 0 Then 'we're counting from last item'convert to count from the first itemItem = .Count + ItemEnd IfSelect Case ItemCase Is < 0'Negative Item originally passed exceeded the'number of submatchesrgxExtract = NullIf FailOnError ThenErr.Raise 9End IfCase Is >= .Count'Positive Item exceeded the number of submatchesrgxExtract = NullIf FailOnError ThenErr.Raise 9End IfCase Else 'valid Item numberrgxExtract = .Item(Item)End SelectEnd WithEnd IfElsergxExtract = NullEnd IfEnd IfEnd With'Tidy up and normal exitIf Not Persist Then Set oRE = NothingExit FunctionErrHandler:If FailOnError ThenWith ErrSelect Case .Number'Replace the default "object-defined error" messageCase 9: .Description = "Subscript out of range (the Item number requested " _& "was greater than the number of matches found, or than the number of " _& "(...) grouping/capturing parentheses in the Pattern)."Case 13: .Description = "Type mismatch, probably because " _& "the ""Target"" argument could not be converted to a string"Case 5017: .Description = "Syntax error in regular expression"Case 5018: .Description = "Unexpected quantifier in regular expression"Case 5019: .Description = "Expected ']' in regular expression"Case 5020: .Description = "Expected ')' in regular expression"Case ElseIf oRE Is Nothing Then 'Failed to create Regexp object.Description = "Could not create VBScript.RegExp object. " & Err.DescriptionElse 'Unexpected error.Description = rgxPROC_NAME & ": " & .DescriptionEnd IfEnd SelectSet oRE = Nothing.Raise Err.Number, rgxPROC_NAME, _rgxPROC_NAME & "(): " & .DescriptionEnd WithElse 'Fail silentlyErr.ClearSet oRE = NothingEnd IfEnd Function
Tags: VBA, string, manipulação, John Nurick,
