Return first instance of email address from text 1

[Moss100]

Hello, I need to return just the first email address from a block of text that contains several email addresses.

I have found the following function whcih returns ALL email addresses from the block. Is there a better way (more efficient) or can this function be editied?

Many thanks
Mark

Public Function ExtractEmailFun(extractStr As String) As String
'Update by extendoffice
Dim CharList As String
On Error Resume Next
CheckStr = "[A-Za-z0-9._-]"
OutStr = ""
Index = 1
Do While True
    Index1 = VBA.InStr(Index, extractStr, "@")
    getStr = ""
    If Index1 > 0 Then
        For p = Index1 - 1 To 1 Step -1
            If Mid(extractStr, p, 1) Like CheckStr Then
                getStr = Mid(extractStr, p, 1) & getStr
            Else
                Exit For
            End If
        Next
        getStr = getStr & "@"
        For p = Index1 + 1 To Len(extractStr)
            If Mid(extractStr, p, 1) Like CheckStr Then
                getStr = getStr & Mid(extractStr, p, 1)
            Else
                Exit For
            End If
        Next
        Index = Index1 + 1
        If OutStr = "" Then
            OutStr = getStr
        Else
            OutStr = OutStr & Chr(10) & getStr
        End If
    Else
        Exit Do
    End If
Loop
ExtractEmailFun = OutStr
End Function

 

[Andrzejek]

...
    Else
        Exit Do
    End If
Loop
[blue]
If InStr(OutStr, Chr(10)) > 0 Then
    OutStr = Split(OutStr, Chr(10)) (0)
End If
[/blue]
ExtractEmailFun = OutStr
End Function

---- Andy

"Hmm...they have the internet on computers now"--Homer Simpson

 

[strongm]

> ALL email addresses from the block

Well, to be pedantic, it returns all alphanumeric (plus . and _) strings that contain an @ rather than an RFC 5322 email address. But, assuming that is good enough for your purposes, this regular expression-based function might prove useful ,as it should return all matched emails as an array of strings.

[blue]Public Function getEmails(strEmail As String) As String()
    Dim lp As Long
    Dim myMatches As Object [COLOR=green]'MatchCollection[/color]
    Dim myStrings() As String
    
    With CreateObject("vbscript.regexp")
        .Global = True
        .Pattern = "[\w._-]+@[\w._-]+" [COLOR=green]'v. simplistic email address matching pattern[/color]
        Set myMatches = .Execute(strEmail)
    End With
    ReDim myStrings(myMatches.Count - 1) As String
    For lp = 0 To myMatches.Count - 1
        myStrings(lp) = myMatches.Item(lp)
    Next
    getEmails = myStrings
End Function[/blue]

 

[hermanlaksko]

The above code from Strongm will give you a very nice list to pick from.
Cool solution

Herman
Say no to macros