VBA Macro integration with Chrome

[heatherc]

Hello there, I hope everyone is well.


My company has a lot of excel vba macros that work with IE. You might be aware that IE is getting discontinued on June 15th therefore the company has requested to transition these automation tools to support chrome.


My question is will SeleniumBasic be able to support such macros considering that Selenium Type Library is enabled?




I know that IE is dependant of OLE Automation reference, therefore I am wondering to what extend would I need to modify the script in order to make it work with SeleniumBasic.

[jdelano]

I would say that it depends on what functionality you're using with IE. You can interact with the web site, like click buttons and read information from it using Selenium. I helped someone on another forum to use Selenium to read some tables on a web site. Here is that code, maybe it helps shed some light on its usage.



Private Sub btnRetrieveData_Click()


' using Selenium to grab the date from the website
' requires Selenium be installed from https://github.com/florentbr/SeleniumBasic/releases/tag/v2.0.9.0
' and a reference to Selenium Type Librarybe made

Dim cDriver As chromeDriver
Dim rfqDatesDict As Scripting.Dictionary
Dim rfqDate As Variant
Dim rfqResult As String
Dim logRow As Long

' is the date to run from an actual date?
On Error Resume Next
If CDate(Sheet1.Cells(2, 2).Value) > Date Then
If Err > 0 Then
MsgBox "The 'Since' date is invalid"
Exit Sub
End If
End If
On Error GoTo 0

' where to start writing the progress information
logRow = Sheet1.Cells(Sheet1.Rows.Count, "A").End(xlUp).Row + 1

' create this and use this one instance throught the code
Set cDriver = New chromeDriver

' get the dates and their associated links, any error here stops everything
On Error Resume Next

Sheet1.Cells(logRow, 1).Value = Format(Date, "MM-DD-YYYY") & " checking for RFQ dates from " & Sheet1.Cells(2, 2).Value
Sheet1.Cells(logRow, 1).Font.Bold = True
logRow = logRow + 1
DoEvents

Set rfqDatesDict = GetRFQDates(cDriver)

If Err <> 0 Then
MsgBox "Error collecting the RFQ dates! Error: " & Error(Err), vbCritical, "ERROR"
cDriver.Quit
Set cDriver = Nothing
Exit Sub
End If

Sheet1.Cells(logRow, 1).Value = Format(Date, "MM-DD-YYYY") & " checking for RFQ dates since " & Sheet1.Cells(2, 2).Value & " found " & CStr(rfqDatesDict.Count)

On Error GoTo 0

' loop the links to extract the data from their page into
' a new sheet named as the date
For Each rfqDate In rfqDatesDict.Keys

' show the progress
Sheet1.Range("A" & CStr(logRow)).EntireRow.Font.Color = vbBlack ' reset font color
Sheet1.Cells(logRow, 2).Value = rfqDate
Sheet1.Cells(logRow, 3).Value = "Reading date's data..."
DoEvents

' call the function that retrieves the RFQ info & creates a new sheet
rfqResult = GetRFQDatesData(rfqDatesDict(rfqDate), cDriver, rfqDate)

' anything but "" is an error
If rfqResult <> "" Then
' error returned, write it to the log and color it red
Sheet1.Cells(logRow, 3).Value = rfqResult
Sheet1.Range("A" & CStr(logRow)).EntireRow.Font.Color = vbRed
Else
' successful processing
Sheet1.Cells(logRow, 3).Value = "New sheet created for " & rfqDate
End If

DoEvents
logRow = logRow + 1

Next rfqDate

' clean up
On Error Resume Next
cDriver.Close
Set cDriver = Nothing
Set rfqDatesDict = Nothing


Sheet1.Cells(logRow, 1).Value = "All dates available have been processed"
Sheet1.Cells(logRow, 1).Font.Bold = True
DoEvents

MsgBox "Done."

End Sub


Private Function GetRFQDates(cDriver As chromeDriver) As Scripting.Dictionary


' first process is to gather the dates and their associated URLs
Dim tblRow As WebElement
Dim tblData As WebElement
Dim rfqDateURLs As Scripting.Dictionary
Dim fromDate As Date
Dim pageDate As Date

cDriver.Get "https://www.dibbs.bsm.dla.mil/RFQ/RfqDates.aspx?category=close"

' wait 5 seconds to allow for chrome to load and display the page
cDriver.Wait 5000

cDriver.FindElementById("butAgree").Click ' try to click the Ok button

' wait 5 seconds to allow for chrome move to the next page
cDriver.Wait 5000

fromDate = CDate(Sheet1.Cells(2, 2).Value)

Set rfqDateURLs = New Scripting.Dictionary

' get the table rows, loop through them to retrieve the data
For Each tblRow In cDriver.FindElementById("ctl00_cph1_dtlDateList").FindElementsByTag("tr")

' get each row of data from the web page table
For Each tblData In tblRow.FindElementsByTag("td")

' if the date is equal to or great than the date
' specified on sheet1 add it to the dictionary for processing
If Trim(tblData.Text) <> "" Then
' there is a date in the table cell
pageDate = CDate(tblData.Text)

If pageDate >= fromDate Then
rfqDateURLs.Add Format(pageDate, "MM-DD-YYYY"), tblData.FindElementByTag("a").Attribute("href")
End If

End If

Next tblData


Next tblRow


Set GetRFQDates = rfqDateURLs

End Function


Private Function GetRFQDatesData(dateURL As Variant, cDriver As chromeDriver, sheetName As Variant) As String


' each dates URL is passed in, this creates a new sheet, and then
' writes the table data found on the URL
Dim rfqTable As WebElement
Dim resultString As String

cDriver.Get dateURL

' wait 5 seconds to allow for chrome to load and display the page
cDriver.Wait 5000

' get the number of records found for the date
Sheet1.Cells(Sheet1.Cells(Sheet1.Rows.Count, "C").End(xlUp).Row, "E").Value = cDriver.FindElementById("ctl00_cph1_lblRecCount").Text

' first look to see if the RFQ grid is available
On Error Resume Next
Set rfqTable = cDriver.FindElementById("ctl00_cph1_grdRfqSearch")

If rfqTable Is Nothing Then
' the required table isn't available, is the okay button in the way?
cDriver.FindElementById("butAgree").Click ' try to click the Ok button

If Err = 0 Then

' wait 5 seconds to allow for chrome to load and display the page
cDriver.Wait 5000


' successfully clicked the okay button, try to get the table again to move on
Set rfqTable = cDriver.FindElementById("ctl00_cph1_grdRfqSearch")

If Not rfqTable Is Nothing Then
' all good go for it
resultString = CreateSheetWriteData(rfqTable, CStr(sheetName), cDriver)
Else
' give up on this page
resultString = "Issue during processing no Okay button or RFQ data grid found! Error: " & Error(Err)

GoTo UnableToProcessTheURLData


End If
Else
' encountered an unknown page or the link is wrong
resultString = "Issue during processing no Okay button or RFQ data grid found! Error: " & Error(Err)

GoTo UnableToProcessTheURLData

End If
Else
' the expected table is available
resultString = CreateSheetWriteData(rfqTable, CStr(sheetName), cDriver)
End If

Set rfqTable = Nothing

UnableToProcessTheURLData:


' there was a problem trying to process the information on the page
' passed in for the RFQ date
If Err <> 0 And Err <> 7 Then resultString = "Encountered an error : " & Error(Err)

GetRFQDatesData = resultString

End Function


Private Function CreateSheetWriteData(rfqTable As WebElement, sheetName As String, cDriver As chromeDriver) As String


Dim rowNum As Long
Dim columCount As Integer

Dim tblRow As WebElement
Dim rfqDateWS As Worksheet
Dim rfqTablePages As WebElement
Dim cl As Range

' create a new sheet for the dates data
On Error Resume Next

Set rfqDateWS = ThisWorkbook.Sheets(sheetName)

If Err <> 0 Then
' no sheet with this name exists, create it
Set rfqDateWS = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Coun t))
rfqDateWS.Name = sheetName

' display sheet1 again
Sheet1.Activate
DoEvents

Else
' there is a sheet in this workbook with this date
If MsgBox("A sheet named '" & sheetName & "' exists. Delete all its data and rewrite the data?", vbYesNo, "Existing Sheet") = vbNo Then
' the user has selected to not overwrite the existing sheets data
CreateSheetWriteData = "User cancelled overwrite of sheet: " & sheetName

Set rfqDateWS = Nothing
Exit Function
Else
' clear out the current data on the existing worksheet
rfqDateWS.Range("A1:I" & Sheet1.Cells(Sheet1.Rows.Count, "A").End(xlUp).Row).Clear
End If
End If


' format the table header row
rfqDateWS.Cells(1, 1).ColumnWidth = 10
rfqDateWS.Cells(1, 2).ColumnWidth = 20
rfqDateWS.Cells(1, 3).ColumnWidth = 30
rfqDateWS.Cells(1, 4).ColumnWidth = 15
rfqDateWS.Cells(1, 5).ColumnWidth = 17
rfqDateWS.Cells(1, 6).ColumnWidth = 15
rfqDateWS.Cells(1, 7).ColumnWidth = 15
rfqDateWS.Cells(1, 8).ColumnWidth = 12
rfqDateWS.Cells(1, 9).ColumnWidth = 12

For Each cl In rfqDateWS.Range("A1:I1").Cells
cl.Interior.Color = RGB(22, 54, 92)
cl.Font.Color = vbWhite

Next cl


' loop through the tables rows to find the data to write to the sheet
Sheet1.Cells(Sheet1.Cells(Sheet1.Rows.Count, "C").End(xlUp).Row, 3).Value = "Reading Page 1"
DoEvents

rowNum = 1
For Each tblRow In rfqTable.FindElementsByTag("tr")

' there are specific table rows to get data from
If tblRow.Attribute("class") = "AwdRecs" Or tblRow.Attribute("class") = "BgWhite" Or tblRow.Attribute("class") = "BgSilver" Then

' get the column headers from the web page table
On Error GoTo 0
columCount = 1
For Each tblHeader In tblRow.FindElementsByTag("th")
rfqDateWS.Cells(rowNum, columCount).Value = tblHeader.Text

columCount = columCount + 1
Next tblHeader

' get each row of data from the web page table
columCount = 1
For Each tblData In tblRow.FindElementsByTag("td")
rfqDateWS.Cells(rowNum, columCount).Value = tblData.Text
columCount = columCount + 1
Next tblData

rowNum = rowNum + 1
End If


Next tblRow


Set rfqTablesPages = Nothing

' check for pages on the RFQ data sheet
Set rfqTablesPages = cDriver.FindElementByClass("pagination")
If Not IsEmpty(rfqTablesPages) Then
' there is a page table present
' call the procedure that will handle writting each page to the current sheet
' starting at the last row used above
WriteDataFromPages cDriver, rfqDateWS, rowNum, 2

Set rfqTablesPages = Nothing

End If

Set rfqTablesPages = Nothing
Set rfqDateWS = Nothing

On Error GoTo 0

CreateSheetWriteData = ""

End Function


Private Function WriteDataFromPages(cDriver As chromeDriver, rfqDateWS As Worksheet, rowNum As Long, rfqLoadPageNumber As Integer) As String

' the page for the RFQ date has a table that contains multiple pages
Dim rfqTablesPages As WebElement
Dim rfqPage As WebElement
Dim rfqTable As WebElement
Dim tblRow As WebElement

Dim columCount As Integer
Dim resultString As String
Dim ignoreFirstElipse As Boolean

On Error GoTo PageProcessingError:

ignoreFirstElipse = False

Sheet1.Cells(Sheet1.Cells(Sheet1.Rows.Count, "C").End(xlUp).Row, 3).Value = "Reading Page " & CStr(rfqLoadPageNumber)
DoEvents

Set rfqTablesPages = cDriver.FindElementByClass("pagination")

For Each rfqPage In rfqTablesPages.FindElementsByTag("td")

If rfqPage.Text = CStr(rfqLoadPageNumber) Then

' make the website load the pagination page
Set rfqTablesPages = Nothing
rfqPage.FindElementByTag("a").Click
cDriver.Wait 5000

' get the rows from the refreshed table for the page number
Set rfqTable = cDriver.FindElementById("ctl00_cph1_grdRfqSearch")

' skipping the TH elements because they are already in the sheet
For Each tblRow In rfqTable.FindElementsByTag("tr")

' only include the rows of data as indicated by their background
If tblRow.Attribute("class") = "BgWhite" Or tblRow.Attribute("class") = "BgSilver" Then
' get each row of data from the web page table
columCount = 1
For Each tblData In tblRow.FindElementsByTag("td")
rfqDateWS.Cells(rowNum, columCount).Value = tblData.Text
columCount = columCount + 1
Next tblData

rowNum = rowNum + 1
End If

Next tblRow

Set rfqTable = Nothing

rfqLoadPageNumber = rfqLoadPageNumber + 1

Set rfqTablesPages = Nothing
WriteDataFromPages cDriver, rfqDateWS, rowNum, rfqLoadPageNumber

ElseIf rfqPage.Text = "..." And ignoreFirstElipse = False Then

' encountered the "next group of pages" button
rfqPage.FindElementByTag("a").Click
cDriver.Wait 5000


rfqLoadPageNumber = rfqLoadPageNumber + 1

Set rfqTablesPages = Nothing
WriteDataFromPages cDriver, rfqDateWS, rowNum, rfqLoadPageNumber

ElseIf rfqPage.Text = "First" Then
' there is sometimes an elipses after the "First" navigation button, this can ge ignored
ignoreFirstElipse = True

End If

Next rfqPage

Set rfqTablesPages = Nothing

Exit Function
PageProcessingError:

resultString = Error(Err)

End Function

[heatherc]

Many thanks for your code. It's helpful to me.

[jdelano]

You're welcome, happy to help. Good luck with your project.