Public Function FindEmailInString(StringToSearch As String) As String
Dim sExp As String
sExp = "\b[A-Z0-9._%+-]+@[A-Z0-9.-]+\.[A-Z]{2,4}\b"
FindEmailInString rgxExtract(StringToSearch, sExp)
End Function
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.MatchCollection
On Error GoTo ErrHandler
rgxExtract = Null 'Default return value
'NB: if FailOnError is false, returns Null on error
If IsMissing(Target) Then
'This is the signal to dispose of oRE
Set oRE = Nothing
Exit Function 'with default value
End If
'Create the RegExp object if necessary
If oRE Is Nothing Then
Set oRE = CreateObject("VBScript.Regexp")
End If
With 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 .IgnoreCase
End If
.Global = True
.Multiline = True
' If Multiline <> .Multiline Then
' .Multiline = Multiline
' End If
If Pattern <> .Pattern Then
.Pattern = Pattern
End If
'Finally, execute the match
If IsNull(Target) Then
rgxExtract = Null
Else
Set oMatches = oRE.Execute(Target)
If oMatches.Count > 0 Then
If oMatches(0).SubMatches.Count = 0 Then
'No ( ) group in Pattern: return the match
If Item < 0 Then 'we're counting from last item
'convert to count from the first item
Item = oMatches.Count + Item
End If
Select Case Item
Case Is < 0
'Negative Item originally passed exceeded the
'number of matches
rgxExtract = Null
If FailOnError Then
Err.Raise 9
End If
Case Is >= oMatches.Count
'Positive Item exceeded the number of matches
rgxExtract = Null
If FailOnError Then
Err.Raise 9
End If
Case Else
rgxExtract = oMatches(Item)
End Select
Else 'There are one or more ( ) captured groups in Pattern
'return the one specified by Item
With oMatches(0).SubMatches
If Item < 0 Then 'we're counting from last item
'convert to count from the first item
Item = .Count + Item
End If
Select Case Item
Case Is < 0
'Negative Item originally passed exceeded the
'number of submatches
rgxExtract = Null
If FailOnError Then
Err.Raise 9
End If
Case Is >= .Count
'Positive Item exceeded the number of submatches
rgxExtract = Null
If FailOnError Then
Err.Raise 9
End If
Case Else 'valid Item number
rgxExtract = .Item(Item)
End Select
End With
End If
Else
rgxExtract = Null
End If
End If
End With
'Tidy up and normal exit
If Not Persist Then Set oRE = Nothing
Exit Function
ErrHandler:
If FailOnError Then
With Err
Select Case .Number
'Replace the default "object-defined error" message
Case 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 Else
If oRE Is Nothing Then 'Failed to create Regexp object
.Description = "Could not create VBScript.RegExp object. " & Err.Description
Else 'Unexpected error
.Description = rgxPROC_NAME & ": " & .Description
End If
End Select
Set oRE = Nothing
.Raise Err.Number, rgxPROC_NAME, _
rgxPROC_NAME & "(): " & .Description
End With
Else 'Fail silently
Err.Clear
Set oRE = Nothing
End If
End Function
|
