Need to add a Regxp to Bulk Email Extractor. - excel VBA - excel

Question

++++++++++++++ I have added new stuff at the bottom today, +++++++++++++++++
#############################################################################
+++++++++++ Edit today 7th Jan 2021 ######## 3:50PM UK TIME +++++++++++
#############################################################################
This is a few days old and I have abandonded it, unless someone can help, for new information please go to the bottom,
I have been attempting to update my code to extract emails using a REGXP rather that Mailto: which it currently used. I posted on S.O a few months back asking for help, which I did receive and I am very grateful for. The new code was much longer than mine and more complicated for me to understand. I a very limited in VBA and was unable to make further changes to the new code. For the past few month I have been trying to update my existing code, with no luck.
As advised I am very limited in VBA, however I do understand my code and would like a MINOR change in it to enable me to extract emails via Regxp. Please DO NOT re-write the whole code, As this was done once and is out of my depth.
This is My Original Code
Sub ScrapeSoMeAndMailAddresses()
'Columns for both tables
Const colUrl As Long = 1 'Must always be the first column
Const colMail As Long = 2 'Must always be the first column before Some platforms
Const colFacebook As Long = 3 'Must always be the last column of Some platforms
Const colError As Long = 4 'Must always be the last column
Dim url As String
Dim http As Object
Dim htmlDoc As Object
Dim nodeAllLinks As Object
Dim nodeOneLink As Object
Dim pageLoadSuccessful As Boolean
Dim tableUrlsOneAddressLeft As String
Dim tableAllAddresses As String
Dim currentRowTableUrls As Long
Dim lastRowTableUrls As Long
Dim currentRowsTableAll(colUrl To colFacebook) As Long
Dim lastRowTableAll As Long
Dim addressCounters(colMail To colFacebook) As Long
Dim checkCounters As Long
'Initialize variables
tableUrlsOneAddressLeft = "Urls" ''Name of Sheet
currentRowTableUrls = 2 'First row for content
tableAllAddresses = "Results" ''Name of Sheet
For checkCounters = colUrl To colFacebook
currentRowsTableAll(checkCounters) = 2 'First rows for content
Next checkCounters
Set htmlDoc = CreateObject("htmlfile")
Set http = CreateObject("MSXML2.ServerXMLHTTP.6.0")
'Clear all contents and comments in the URL source sheet from email column to error column
With Sheets(tableUrlsOneAddressLeft)
lastRowTableUrls = .Cells(Rows.Count, colUrl).End(xlUp).Row
.Range(.Cells(currentRowTableUrls, colMail), .Cells(lastRowTableUrls, colError)).ClearContents
.Range(.Cells(currentRowTableUrls, colMail), .Cells(lastRowTableUrls, colError)).ClearComments
End With
'Delete all rows except headline in the sheet with all addresses
lastRowTableAll = Sheets(tableAllAddresses).Cells(Rows.Count, colUrl).End(xlUp).Row
Sheets(tableAllAddresses).Rows(currentRowsTableAll(colUrl) & ":" & lastRowTableAll).Delete Shift:=xlUp
'Loop over all URLs in column A in the URL source sheet
Do While Sheets(tableUrlsOneAddressLeft).Cells(currentRowTableUrls, 1).Value <> ""
'Scroll for visual monitoring, if 'the sheet with the URLs are the
'active one
If ActiveSheet.Name = tableUrlsOneAddressLeft Then
If currentRowTableUrls > 14 Then
ActiveWindow.SmallScroll down:=1
End If
Sheets(tableUrlsOneAddressLeft).Cells(currentRowTableUrls, 1).Select
End If
'Get next url from the URL source sheet
url = Sheets(tableUrlsOneAddressLeft).Cells(currentRowTableUrls, colUrl).Value
'Try to load page 'Temporarily disable error handling if 'there is a timeout or onother error
On Error Resume Next
http.Open "GET", url, False
http.send
'Check if page loading was successful
If Err.Number = 0 Then
pageLoadSuccessful = True
End If
On Error GoTo 0
If pageLoadSuccessful Then
'Build html document for DOM operations
htmlDoc.body.innerHtml = http.responseText
'Create node list from all links of the page
Set nodeAllLinks = htmlDoc.getElementsByTagName("a")
'Walk through all links of the node list
For Each nodeOneLink In nodeAllLinks
'''#####################################################################################################
'''################################### THIS IS THE START OF THE EMAIL SECTION ##########################
'''#####################################################################################################
'Check for mail address
If InStr(1, nodeOneLink.href, "mailto:") Then
'Write mail address to both tables
Sheets(tableUrlsOneAddressLeft).Cells(currentRowTableUrls, colMail).Value = Right(nodeOneLink.href, Len(nodeOneLink.href) - InStr(nodeOneLink.href, ":"))
Sheets(tableAllAddresses).Cells(currentRowsTableAll(colMail), colMail).Value = Right(nodeOneLink.href, Len(nodeOneLink.href) - InStr(nodeOneLink.href, ":"))
'Check if it is a new line in the sheet with all addresses
If currentRowsTableAll(colMail) >= currentRowsTableAll(colUrl) Then
'Write URL in the new line of the sheet with all addresses
Sheets(tableAllAddresses).Cells(currentRowsTableAll(colUrl), colUrl).Value = url
'Increment url counter
currentRowsTableAll(colUrl) = currentRowsTableAll(colUrl) + 1
End If
'Increment mail counters
currentRowsTableAll(colMail) = currentRowsTableAll(colMail) + 1
addressCounters(colMail) = addressCounters(colMail) + 1
End If
'''#####################################################################################################
'''################################### END OF THE EMAIL SECTION ########################################
'''#####################################################################################################
'Check for Facebook address
If InStr(1, UCase(nodeOneLink.href), "FACEBOOK") Then
'Write Facebook address to both tables
Sheets(tableUrlsOneAddressLeft).Cells(currentRowTableUrls, colFacebook).Value = nodeOneLink.href
Sheets(tableAllAddresses).Cells(currentRowsTableAll(colFacebook), colFacebook).Value = nodeOneLink.href
'Check if it is a new line in the sheet with all addresses
If currentRowsTableAll(colFacebook) >= currentRowsTableAll(colUrl) Then
'Write URL in the new line of the sheet with all addresses
Sheets(tableAllAddresses).Cells(currentRowsTableAll(colUrl), colUrl).Value = url
'Increment url counter
currentRowsTableAll(colUrl) = currentRowsTableAll(colUrl) + 1
End If
'Increment Facebook counters
currentRowsTableAll(colFacebook) = currentRowsTableAll(colFacebook) + 1
addressCounters(colFacebook) = addressCounters(colFacebook) + 1
End If
Next nodeOneLink
'Check address counters
For checkCounters = colMail To colFacebook
'Set comment if more than 1 link were found
If addressCounters(checkCounters) > 1 Then
Sheets(tableUrlsOneAddressLeft).Cells(currentRowTableUrls, checkCounters).AddComment Text:=CStr(addressCounters(checkCounters))
Sheets(tableUrlsOneAddressLeft).Cells(currentRowTableUrls, checkCounters).Comment.Shape.TextFrame.AutoSize = True
End If
Next checkCounters
Else
'Page not loaded
'Write message URL table
Sheets(tableUrlsOneAddressLeft).Cells(currentRowTableUrls, colError).Value = "Error with URL or timeout"
End If
'Prepare for next page
pageLoadSuccessful = False
Erase addressCounters
lastRowTableAll = Sheets(tableAllAddresses).Cells(Rows.Count, colUrl).End(xlUp).Row
For checkCounters = colUrl To colFacebook
currentRowsTableAll(checkCounters) = lastRowTableAll + 1 'First rows for next page content
Next checkCounters
currentRowTableUrls = currentRowTableUrls + 1
Loop
'Clean up
Set http = Nothing
Set htmlDoc = Nothing
Set nodeAllLinks = Nothing
Set nodeOneLink = Nothing
End Sub
This is the Original Post on S.O with the new code that is out of my depth.
My Post on S.O
In the above link there is the new code and a regxp in it, however I can not adapt this code to work with mine. If its RegXP function can be used and adapted with my code, then that would be super.
I have also tried to use this Regxp within my code, but with NO luck. In my above code I ONLY NEED THE EMAIL part updating and NOT the whole code re-written.
For Each link In links
'Set doc = NewHTMLDocument(CStr(link))
Set Html = NewHTMLDocument(CStr(link))
With regxp
''' ########## Phone Numbers Pattern ###########
.Pattern = "(?:\+1)?(?:\+[0-9])?\(?([0-9]{4})\)?[-. ]?([0-9]{4})[-. ]?([0-9]{3}?)" '"(?:\+1)?(?:\+[0-9])?\(?([0-9]{3})\)?[-. ]?([0-9]{3})[-. ]?([0-9]{3}?)"
.Global = False
.IgnoreCase = True
Set phone_list = .Execute(Html.body.innerHtml)
''' ########## Email Pattern ###########
.Pattern = "([a-zA-Z0-9_\-\.]+)#((\[[0-9]{1,3}\.[0-9]{1,3}\.[0-9]{1,3}\.)|(([a-zA-Z0-9\-]+\.)+))([a-zA-Z]{2,4}|[0-9]{1,3})(\]?)"
.Global = False
.IgnoreCase = True
Set email_list = .Execute(Html.body.innerHtml)
'######## Edit today 6th Jan 2021 ######## 6:00PM UK TIME
if I change this
If InStr(1, nodeOneLink.href, "mailto:") Then
To This
If InStr(1, nodeOneLink.href, "#") Then
Then I get slightly better results, Ideally I would like a regxp, if any one could help that would be super as I am stuck on this and can not go any futher
##################################################################
'######## Edit today 6th Jan 2021 ######## 8:00PM UK TIME
###################################################################
I was advised that this is the regxp that I need
Private Function GetEmailAddressesFromHtml(ByVal htmlDocument As Object) As Collection
' Should return a collection of strings representing email addresses detected
' in the HTML document.
Dim outputCollection As Collection
Set outputCollection = New Collection
Dim regEx As Object
Set regEx = CreateObject("VBScript.RegExp")
With regEx
.Pattern = "[a-zA-Z0-9_.+-]+#[a-zA-Z0-9-]+\.[a-zA-Z0-9-.]+"
.Global = True
Dim emailMatches As Object
Set emailMatches = .Execute(htmlDocument.body.innerHTML)
End With
Dim matchFound As Object
For Each matchFound In emailMatches
On Error Resume Next ' De-duplicate here.
outputCollection.Add matchFound.Value, Key:=matchFound.Value
On Error GoTo 0
Next matchFound
Set GetEmailAddressesFromHtml = outputCollection
End Function
And that it needs to go here
Dim colEmails as collection
Set colEmails = GetEmailAddressesFromHtml(htmlDoc)
If colEmails.Length >0 then
*****ADD YOUR CODE HERE****
End If
However I have been trying for months now and can not work it out. If someone can advise that would be super.
#############################################################################
+++++++++++++Edit today 7th Jan 2021 ######## 3:50PM UK TIME ++++++++++++
#############################################################################
I have simplified the code, so now I have the regxp for emails and phones, however I can not workout the part on how to add the code to extract social media links.
New Code
Private Sub CommandButton1_Click()
Dim wb As Workbook
Dim wsSheet As Worksheet, links As Variant, link As Variant
Dim rw As Long
Dim regxp As New RegExp, post As Object, phone_list As Object, email_list As Object
Dim Html As New HTMLDocument
''''SHEET1 as sheet with URL
Set wb = ThisWorkbook
Set wsSheet = wb.Sheets("Sheet1")
rw = wsSheet.Cells(wsSheet.Rows.Count, "A").End(xlUp).Row
links = wsSheet.Range("A2:A" & rw)
For Each link In links
'Set doc = NewHTMLDocument(CStr(link))
Set Html = NewHTMLDocument(CStr(link))
With regxp
''' ########## Phone Numbers Pattern ###########
.Pattern = "(?:\+1)?(?:\+[0-9])?\(?([0-9]{4})\)?[-. ]?([0-9]{4})[-. ]?([0-9]{3}?)" '"(?:\+1)?(?:\+[0-9])?\(?([0-9]{3})\)?[-. ]?([0-9]{3})[-. ]?([0-9]{3}?)"
.Global = False
.IgnoreCase = True
Set phone_list = .Execute(Html.body.innerHtml)
''' ########## Email Pattern ###########
.Pattern = "([a-zA-Z0-9_\-\.]+)#((\[[0-9]{1,3}\.[0-9]{1,3}\.[0-9]{1,3}\.)|(([a-zA-Z0-9\-]+\.)+))([a-zA-Z]{2,4}|[0-9]{1,3})(\]?)"
.Global = False
.IgnoreCase = True
Set email_list = .Execute(Html.body.innerHtml)
'''########## PHONE LIST ############# ADD TO SHEET
On Error Resume Next
If phone_list(0) Is Nothing Then
On Error Resume Next
Sheet1.Cells(Sheet1.Cells(Sheet1.Rows.Count, "B").End(xlUp).Row + 1, "B").Value = "-"
Else
On Error Resume Next
Sheet1.Cells(Sheet1.Cells(Sheet1.Rows.Count, "B").End(xlUp).Row + 1, "B").Value = phone_list(0)
End If
'''########## EMAIL LIST ############# ADD TO SHEET
On Error Resume Next
If email_list(0) Is Nothing Then
On Error Resume Next
Sheet1.Cells(Sheet1.Cells(Sheet1.Rows.Count, "C").End(xlUp).Row + 1, "C").Value = "-"
Else
On Error Resume Next
Sheet1.Cells(Sheet1.Cells(Sheet1.Rows.Count, "C").End(xlUp).Row + 1, "C").Value = email_list(0)
End If
End With
''''navigate links
Next link
End Sub
Public Function NewHTMLDocument(strURL As String) As Object
Dim objHTTP As Object, objHTML As Object, strTemp As String
Set objHTTP = CreateObject("MSXML2.ServerXMLHTTP")
objHTTP.Open "GET", strURL, False
objHTTP.send
If objHTTP.Status = 200 Then
strTemp = objHTTP.responseText
Set objHTML = CreateObject("htmlfile")
objHTML.body.innerHtml = strTemp
Set NewHTMLDocument = objHTML
Else
'There has been an error
End If
End Function
I need something like this added to the above code
Html.body.innerHTML = http.responseText
Set links = Html.getElementsByTagName("a")
'''COLUMN D = TWITTER
For Each link In links
If InStr(UCase(link.outerHTML), "FACEBOOK") Then
website.Offset(0, 3).Value = link.href
End If
'''COLUMN E = TWITTER
If InStr(UCase(link.outerHTML), "TWITTER") Then
website.Offset(0, 4).Value = link.href
End If
Next
This is the Full Code from where the above code snip is from. I do not need all of what is below, only the part to extract social media links. I have also posed here My Post On Mr Excel
Dim counter As Long
Dim website As Range
Dim row As Long
Dim continue As Boolean
Dim respHead As String
''''The row where website addresses start
row = 2
continue = True
Set http = CreateObject("MSXML2.ServerXMLHTTP.6.0")
Do While continue
'''Could set this to first cell with URL then OFFSET columns to get next web site
Set website = ThisWorkbook.Worksheets("Sheet1").Range("A" & row)
If Len(website.Value) < 1 Then
continue = False
Exit Sub
End If
If website Is Nothing Then
continue = False
End If
'''Debug.Print website
With http
On Error Resume Next
.Open "GET", website.Value, False
.send
'''If the website sent a valid response to our request, URLS ARE IN COLUMN A
If Err.Number = 0 Then
If .Status = 200 Then
Html.body.innerHTML = http.responseText
Set links = Html.getElementsByTagName("a")
'''COLUMN D = TWITTER
For Each link In links
If InStr(UCase(link.outerHTML), "FACEBOOK") Then
website.Offset(0, 3).Value = link.href
End If
'''COLUMN E = TWITTER
If InStr(UCase(link.outerHTML), "TWITTER") Then
website.Offset(0, 4).Value = link.href
End If
Next
End If
Set website = Nothing
Else
'''Debug.Print "Error loading page IN COLUMN H"
website.Offset(0, 8).Value = "Error with website address"
End If
On Error GoTo 0
End With
row = row + 1
Loop
Complete.Show '#### THIS FORM DOES NOT SHOW AT THE END ####
''' CLOSE BROWSER
IE.Quit
Set IE = Nothing
Set ElementCol = Nothing