Extract email addresses from a link (it works but to extend its power)

[BNCOXUK]

Hi everyone,

I found a nice macro which allows me to extract an email from a weblink as below.

Function GetEmail(URL As String)
    Dim IE As Object, WebText As String
    Set IE = CreateObject("InternetExplorer.Application")
    IE.Navigate URL
    While IE.ReadyState <> 4
        DoEvents
    Wend
    WebText = IE.Document.body.innerHTML
    IE.Quit
    Set IE = Nothing
    GetEmail = GetEmailAddress(WebText)
End Function

Function GetEmailAddress(ByVal S As String) As String
    Dim X As Long, AtSign As Long
    Dim Locale As String, Domain As String
    Locale = "[A-Za-z0-9.!#$%&'*/=?^_`{|}~+-]"
    Domain = "[A-Za-z0-9._-]"
    AtSign = InStr(S, "@")
    If AtSign = 0 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

This macro is quite nice but it is not powerful enought. For example, it just finds anything starting with @. I just wants to search the following keywords for email addresses - if they are found then show it in that cell. If there are more than one keywords found, then the enhanced macro will put additional emails along the line. Please help me improve this code so that: it pulls out all email addresses containing the keywords below.

admin
contact
enquiry
hello
info
mail
office

[BNCOXUK]

Can any VBA guru please look into this query?

[JEC.]

This could be your function

Function jec(cell As String) As String
 With CreateObject("vbscript.regexp")
   .Global = True
   .ignorecase = True
   .Pattern = "\b(admin|contact|enquiry|hello|info|mail|office)\b"
    For Each it In Filter(Split(cell), "@", 1)
      If .test(it) Then jec = jec & IIf(jec = "", "", ", ") & it
    Next
 End With
End Function

[BNCOXUK]

Hi JEC. Thank you for your help. Your code may not be the one I am looking for.

For my original code, if I type: =GetEmail("www.londoncarpetandflooring.com"), it will show: [email protected]. Here, 'info' is a keyword. We know other websites may have various emails like office, contact, enquiry. I just need to extract these email addresses. If the email address [email protected] does not contain any of the keywords, then just ignore it.

[JEC.]

Can you post some sample data with desired results?

[BNCOXUK]

Hi JEC, please find the attached sample here. A description of the question is added.

Can you post some sample data with desired results?

[JEC.]

Alright, how about this function, instead of the getemailaddress function. This function is separating by comma's when there are more matches (It leaves out double email addresses)
Note that your file is getting very slow, because it extracts all webpages after every calculation.

Edit: made small adaption in the code to be more efficiënt.

Function jec(cell As String) As String
 Dim it, objMatches
 With CreateObject("vbscript.regexp")
   .Global = True
   .ignorecase = True
   .Pattern = "([a-zA-Z0-9_\-\.]+)@[a-z0-9-]+(\.[a-z0-9-]+)*(\.[a-z]{2,3})"
    Set objMatches = .Execute(cell)
   .Pattern = "\b(" & Join(Application.Transpose(Range("D1:D18")), "|") & ")\b"
    For Each it In objMatches
        If .Test(it) And InStr(1, jec, it, 1) = 0 Then jec = jec & IIf(jec = "", "", ", ") & it
    Next
 End With
End Function

[BNCOXUK]

Hi JEC, thanks for your kind help again. I may have failed to explain my question clearly.

I'd better provide an example. Assume a website called: www.xxx.com. On that page, if you check 'View page source', it will show the html script. The page shows many text strings like @&quot, @media, [email protected], ... The original macro I posted will only extract the first text containing @. In this case, the function =GetEmail("www.xxx.com") will simply return @&quot which is not an email at all. That is why I need to test whether the returned text contains a keyword listed above.

If I directly use your function, then it will not work because your function is based on the condition a proper email has been extracted.

My question is very simple: how to make a macro which will extract all email addresses in a webpage that contain the keywords in the list? My original macro is simply to extract the first string that contains @. This is not interesting at all.

The enhanced macro is expected to extract all valid email addresses (with specific keywords) in a webpage and put them in Excel.

[JEC.]

But if I paste your html page in a cell and use my function, it works as desired I guess.

See file

[BNCOXUK]

Hi JEC, if I need to paste the html page, then it is not the point of having a macro to automate it. The original macro simply uses a user defined function with the website address as the input to extract data.

[JEC.]

Pasting the page was just to show you the output of the function. Ofcourse you can use it like you did before. Just switch them.

[BNCOXUK]

Hi JEC,

I have to say your macro is incredibly good and neat. I tried - It actually delivered the expected results. Thank you so much. I learned from you as a guru.

Hope this macro can be valuable to a lot of others in this forum. The credit goes to you!

[BNCOXUK]

Hi JEC, I tested another site and found the macro resulted in error. Can you please have a look at the attached example here?

[BNCOXUK]

Hi JEC, if you try it as: =jec(GetEmail("https://www.lazylawn.co.uk/contact")). The result will show #VALUE!

Thank you for updating it.

[BNCOXUK]

Can anyone please have a look at the query? Thank you.

[JEC.]

Ok how about

Function getmail(url As String) As String
 With CreateObject("internetexplorer.application")
   .navigate url
    Do While .ReadyState = 4: DoEvents: Loop
    Do Until .ReadyState = 4: DoEvents: Loop
    getmail = jec(.document.body.innerhtml)
 End With
End Function

Function jec(cell As String) As String
 Dim it, objMatches
 With CreateObject("vbscript.regexp")
   .Global = True
   .ignorecase = True
   .Pattern = "([a-zA-Z0-9_\-\.]+)@[a-z0-9-]+(\.[a-z0-9-]+)*(\.[a-z]{2,3})"
    Set objMatches = .Execute(cell)
   .Pattern = "\b(" & Join(Application.Transpose(Range("D1:D20")), "|") & ")\b"
    For Each it In objMatches
        If .Test(it) And InStr(1, jec, it, 1) = 0 Then jec = jec & IIf(jec = "", "", ", ") & it
    Next
 End With
End Function

Only call

=getmail(A2)

[BNCOXUK]

Hi JEC, your macro is just incredible. It works perfectly. Thank you so much.

By the way, if I want to extract all emails shown on a webpage, what would be the updated code? There is a nice website for testing:

[JEC.]

Good to hear! If you want to extract every email, some code can be removed. It still leaves out double emails with this instr-check
Cheers!

Function getmail(url As String) As String
 With CreateObject("internetexplorer.application")
   .navigate url
    Do While .ReadyState = 4: DoEvents: Loop
    Do Until .ReadyState = 4: DoEvents: Loop
    getmail = jec(.document.body.innerhtml)
 End With
End Function

Function jec(cell As String) As String
 Dim it
 With CreateObject("vbscript.regexp")
   .Global = True
   .ignorecase = True
   .Pattern = "([a-zA-Z0-9_\-\.]+)@[a-z0-9-]+(\.[a-z0-9-]+)*(\.[a-z]{2,3})"
    For Each it In .Execute(cell)
        If InStr(1, jec, it, 1) = 0 Then jec = jec & IIf(jec = "", "", ", ") & it
    Next
 End With
End Function

[BNCOXUK]

Hi JEC, the code really looks powerful and neat. Thanks a lot. It works perfectly well.

If possible, is it easy to extract a telephone number from a website using a separate function? Not sure if this is possible? Maybe search keywords like Tel:, Phone, Telephone and then extract the string follow these keywords?

Please forget about it if this sounds difficult to achieve. the email code has been a big help to me.

[JEC.]

You're welcome! Extracting phone numbers is possible as well, as long as you provide enough sample data Maybe start a different topic about that

[BNCOXUK]

Many thanks, JEC. I really appreciate your help. The code you made will be useful to a lot of users. I can now end this topic with a nice solution.

[JEC.]

nice, goodluck!