Extract an email address from Comments field 1

[LimitedTech]

I have a table. It has a comments field in it. This has been used to keep email addresses in it. Unfortunately it has also been used to keep other information. (phone numbers, contact names, general notes). Is there a way to extract the email addresses without doing a manual C&P? With the email addresses being different lengths and at different places in the box, I am at a loss as to how to accomplish this.

Thanks

 

[dhookom]

Are there any other "@" symbols in the field other than in the email addresses?

Duane
Hook'D on Access
MS Access MVP

 

[LimitedTech]

Not that I am aware of.

 

[MajP]

You could then use a function that uses regular expressions. It could find any string that contains a @ and then return the Match collection of all of these strings. Once you find it what yould you do with the results?

 

[LimitedTech]

I am planning on putting the email addresses in their own text field.

 

[dhookom]

You could use a user-defined function like:

Public Function ExtractEmail(varText As Variant) As Variant
    Dim intAtAt As Integer
    Dim intChar As Integer
    Dim strChar As String
    Dim strEmail As String
    If IsNull(varText) Or InStr(varText & "", "@") = 0 Then
        ExtractEmail = Null
     Else
        intAtAt = InStr(varText, "@")
        For intChar = intAtAt To 1 Step -1
            strChar = Mid(varText, intChar, 1)
            If strChar = " " Then
                Exit For
             Else
                strEmail = strChar & strEmail
            End If
        Next
        For intChar = intAtAt To Len(varText)
            strChar = Mid(varText, intChar, 1)
            If strChar = " " Then
                Exit For
             Else
                strEmail = strEmail & strChar
            End If
        Next
    End If
    ExtractEmail = strEmail
End Function

In a query, this might look like

  Email: ExtractEmail([Comments Field])

Duane
Hook'D on Access
MS Access MVP

 

[MajP]

I interpreted this to mean multiple emails. You could then wrap Duane's function with another function to iterate through each @ character.
You can also use regular expressions to find all of the emails and return a collection. Then decide what you want to do with them.

Public Function ReturnMatches(strWord As String) As VBScript_RegExp_55.MatchCollection
  'This function returns a collection of emails found in a string
  'Need Microsoft VBScript Regular Expressions
   Dim objRegExp As VBScript_RegExp_55.RegExp
   Dim objMatch As VBScript_RegExp_55.match
   Dim myPattern As String

   'Match for all emails
   myPattern = "([a-zA-Z0-9._-]+@[a-zA-Z0-9._-]+\.[a-zA-Z0-9._-]+)"
  'Create a regular expression object.
   Set objRegExp = New RegExp
  'Set the pattern by using the Pattern property.
   objRegExp.Pattern = myPattern
  'Set Case Insensitivity.
   objRegExp.ignorecase = False
  'Set global applicability. Not sure what that does
   objRegExp.Global = True
  'Test whether the String can be compared. Not sure what that does
  If (objRegExp.test(strWord) = True) Then
     Set ReturnMatches = objRegExp.Execute(strWord)   ' Execute search.
     'lets assume you only get one match
   Else
     Debug.Print "Could not compare string"
   End If
 '
End Function

This examples uses the collection to read the records and write to a new field in a format seperated by a semicolon. If you are in fact getting multiple emails you would want to more likely save in a child table.

Public Sub ExtractEmails()
  Const tableName = "tblComments"
  Const oldField = "Comment"
  Const newField = "Emails"
  Dim rs As dao.Recordset
  Dim oldComment As String
  Dim emails As VBScript_RegExp_55.MatchCollection
  
  
  Set rs = CurrentDb.OpenRecordset(tableName)
  'loop the recordset
  Do While Not rs.EOF
    oldComment = rs.Fields(oldField)
    Set emails = ReturnMatches(oldComment)
    If Not emails Is Nothing Then
      rs.Edit
        rs.Fields(newField) = GetStringEmails(emails)
      rs.Update
    End If
    rs.MoveNext
  Loop
 
 End Sub

Public Function GetStringEmails(emails As VBScript_RegExp_55.MatchCollection) As String
  'send in a collection and send out a concatenated string
  Dim email As VBScript_RegExp_55.match
  For Each email In emails
      If GetStringEmails = "" Then
        GetStringEmails = email
      Else
        GetStringEmails = GetStringEmails & "; " & email
      End If
  Next email
End Function

Here is a test

jeligarrewa-8453@yopmail.com    The brief sound clarifys the approval oppobobett-7308@yopmail.com The linen boughts the sand stone@meekness.com The cooing manager begins the cough.  ca-tech@dps.centrin.net.id  and then there was trinanda_lestyowati@telkomsel.co.id

and the output in the table looked like this

jeligarrewa-8453@yopmail.com; 
oppobobett-7308@yopmail.com; 
stone@meekness.com; 
ca-tech@dps.centrin.net.id; 
trinanda_lestyowati@telkomsel.co.id

 

[LimitedTech]

Thanks for this, both of you.

 

[Andrzejek]

MajP and Duane gave you an excellent solution. They deserve stars for their effort, don’t you think?

Have fun.

---- Andy

A bus station is where a bus stops. A train station is where a train stops. On my desk, I have a work station.

 

[LimitedTech]

I finally am able to try this. Couple issues;
The Extracted Emails have two @ symbols. so JohnDoe@domain.com returns JohnDoe@@domain.com
Some fields don't extract correctly and example is;
In the MemComments field (A memo field)
SOCHE
VICTOR MORANO
1continentalexpress@gmail.com

Returns: MORANO

In the MemComments field:
(206) 422-5540

umidcfalogistics@gmail.com

Returns: 422-5540

Now I think can fix this on my own by removing the carriage returns and just replace @@ with @ but I wanted to post here so you would know the results. I used Dhookum's code.

 

[MajP]

Should fix it.

Public Function ExtractEmail(varText As Variant) As Variant
    Dim intAtAt As Integer
    Dim intChar As Integer
    Dim strChar As String
    Dim strEmail As String
    If IsNull(varText) Or InStr(varText & "", "@") = 0 Then
        ExtractEmail = Null
     Else
        intAtAt = InStr(varText, "@")
        For intChar = intAtAt To 1 Step -1
            strChar = Mid(varText, intChar, 1)
            If strChar = " " Or strChar = Chr(10) Or strChar = Chr(13) Then
                Exit For
             Else
                strEmail = strChar & strEmail
            End If
        Next
        For intChar = intAtAt To Len(varText)
            strChar = Mid(varText, intChar, 1)
            If strChar = " " Or strChar = Chr(10) Or strChar = Chr(13) Then
                Exit For
             Else
                strEmail = strEmail & strChar
            End If
        Next
    End If
    ExtractEmail = Replace(strEmail, "@@", "@")
End Function

 

[MajP]

I tested my code in the following query

SELECT tblData.MemoFld, 
 getEmails([memofld]) AS Emails
FROM tblData;

Public Function GetEmails(varText As Variant) As String
  Dim Emails As VBScript_RegExp_55.MatchCollection
  If Not IsNull(varText) Then
    Set Emails = ReturnMatches(CStr(varText))
    GetEmails = GetStringEmails(Emails)
  End If
End Function
Public Function ReturnMatches(strWord As String) As VBScript_RegExp_55.MatchCollection
  'This function returns a collection of emails found in a string
  'Need Microsoft VBScript Regular Expressions
   Dim objRegExp As VBScript_RegExp_55.RegExp
   Dim objMatch As VBScript_RegExp_55.match
   Dim myPattern As String

   'Match for all emails
   myPattern = "([a-zA-Z0-9._-]+@[a-zA-Z0-9._-]+\.[a-zA-Z0-9._-]+)"
  'Create a regular expression object.
   Set objRegExp = New RegExp
  'Set the pattern by using the Pattern property.
   objRegExp.Pattern = myPattern
  'Set Case Insensitivity.
   objRegExp.ignorecase = False
  'Set global applicability. Not sure what that does
   objRegExp.Global = True
  'Test whether the String can be compared. Not sure what that does
  If (objRegExp.test(strWord) = True) Then
     Set ReturnMatches = objRegExp.Execute(strWord)   ' Execute search.
     'lets assume you only get one match
   Else
     Debug.Print "Could not compare string"
   End If
 '
End Function
Public Function GetStringEmails(Emails As VBScript_RegExp_55.MatchCollection) As String
  'send in a collection and send out a concatenated string
  Dim email As VBScript_RegExp_55.match
  For Each email In Emails
      If GetStringEmails = "" Then
        GetStringEmails = email
      Else
        GetStringEmails = GetStringEmails & "; " & email
      End If
  Next email
End Function

It handles both of those cases and can handle the combined case where they are both in the same memo field.

MemoFld                                Emails

"SOCHE                                1continentalexpress@gmail.com; umidcfalogistics@gmail.com
VICTOR MORANO
1continentalexpress@gmail.com 
(206) 422-5540
 
umidcfalogistics@gmail.com
 
Returns: 422-5540"