VBA Macro integration with Chrome

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.

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.

Code:

---

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.Count))
        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

---

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

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