Give the following function a try. The first argument is the text string to parse and the optional second argument allows you to start the search from an arbitrary location within the text. If the function finds the first @ sign after the StartAt value (optional, defaulted to 1) and if that @ sign is not part of an email address, then the function returns the empty string. You will need to set up a loop that starts looking one character after each @ sign until it finds a valid email address.
Code:
Function GetEmailAddress(ByVal S As String, Optional StartAt As Long = 1) As String
Dim X As Long, AtSign As Long
Dim Locale As String, Domain As String
S = Mid(S, StartAt)
Locale = "[A-Za-z0-9.!#$%&'*/=?^_`{|}~+-]"
Domain = "[A-Za-z0-9._-]"
AtSign = InStr(S, "@")
If AtSign < 2 Then Exit Function
If Not Mid(S, AtSign - 1, 1) Like Locale Then Exit Function
For X = AtSign To 1 Step -1
If Not Mid(" " & S, X, 1) Like Locale Then
S = Mid(S, X)
If Left(S, 1) = "." Then S = Mid(S, 2)
Exit For
End If
Next
AtSign = InStr(S, "@")
For X = AtSign + 1 To Len(S) + 1
If Not Mid(S & " ", X, 1) Like Domain Then
S = Left(S, X - 1)
If Right(S, 1) = "." Then S = Left(S, Len(S) - 1)
GetEmailAddress = S
Exit For
End If
Next
End Function
Bookmarks