I am working in vba and trying fill in the form in this website and get the output Link Here
There is a problem when i try to fill in the input box from/to airport. This is what i have tried: This function is being called to fill in from/to airport fields
Function enter_get_name(ByVal iedoc As HTMLDocument, _
ByVal input_box As String, ByVal iata As String, _
ByVal id As String, ByRef str As Variant) As Boolean
Dim noopt As Integer ' length of string that appear on drop down menu if no option available
noopt = Len("If your destination does not appear among the cities listed in the destination box")
iedoc.getElementsByName(input_box)(0).innerText = iata ' enter string
Set drop_down = iedoc.getElementById(id).getElementsByTagName("li")
Do While drop_down.Length = 0: DoEvents: Loop ' wait for the drop down menu to come up
If Len(drop_down(0).innerText) = noopt Then ' if option do not exist
enter_get_name = False ' return value
Exit Function ' exit
Else
For Each Name In drop_down ' loop all options of drop down menu
' if found a exact same IATA code, click that html element
str = Mid(Name.innerText, Len(Name.innerText) - 4, 3)
If StrComp(iata, str, 1) = 0 Then
Name.Click
Exit For
End If
Next
enter_get_name = True
End If
End Function
So I have tried to loop all options available in the dropdown, find that element, then click it. The code can find the element successfully, but when i try to .click that element, it does not work sometimes. For example, i have a flight From HKG To SIN as input.
There is 2 options for the arrival(TO) airport: HEL and SIN, it somehow clicked HEL. However, if i do it the other way around, ie: From SIN to HKG, there is no problem with selecting SIN with 10+ options available. How can i resolve this? Any help would be appreciated.
The following uses regex to search the suggested list for the right entry and then click. I'd like to knock out some of the admittedly short hardcoded delays but haven't yet seen a reliable way to ensure dropdown list is fully populated , given it is continuously populated from ajax calls, without such measures.
Public Sub GetInfo()
Dim d As WebDriver, i As Long, t As Date
Const MAX_WAIT_SEC As Long = 10
Const Url = "https://applications.icao.int/icec"
Const FROM As String = "HKG"
Const GOING_TO As String = "SIN"
Dim re As Object
Set d = New ChromeDriver
Set re = CreateObject("vbscript.regexp")
With d
.Start "Chrome"
.get Url
.FindElementByCss("[name=frm1]").SendKeys FROM
Application.Wait Now + TimeSerial(0, 0, 1)
Dim fromSelection As Object
t = Timer
Do
Set fromSelection = .FindElementsByCss("#ui-id-1 li")
If Timer - t > MAX_WAIT_SEC Then Exit Do
Loop While fromSelection.Count = 0
If .FindElementsByCss("#ui-id-1 li").Count = 0 Then Exit Sub
If .FindElementsByCss("#ui-id-1 li").Count = 1 Then
.FindElementsByCss("#ui-id-1 li").item(1).Click
Else
On Error Resume Next
For i = 1 To .FindElementsByCss("#ui-id-1 li").Count
If MatchFound(re, .FindElementsByCss("#ui-id-1 li").item(i).Text, "\(" & FROM & "[ \t]\)") Then
.FindElementsByCss("#ui-id-1 li").item(i).Click
Exit For
End If
Next
On Error GoTo 0
End If
.FindElementByCss("[name=to1]").SendKeys GOING_TO
Application.Wait Now + TimeSerial(0, 0, 1)
Dim toSelection As Object
t = Timer
Do
Set toSelection = .FindElementsByCss("#ui-id-2 li")
If Timer - t > MAX_WAIT_SEC Then Exit Do
Loop While toSelection.Count = 0
If .FindElementsByCss("#ui-id-2 li").Count = 0 Then Exit Sub
If .FindElementsByCss("#ui-id-2 li").Count = 1 Then
.FindElementsByCss("#ui-id-2 li").item(1).Click
Else
On Error Resume Next
For i = 1 To .FindElementsByCss("#ui-id-2 li").Count
If MatchFound(re, .FindElementsByCss("#ui-id-2 li").item(i).Text, "\(" & GOING_TO & "[ \t]\)") Then
.FindElementsByCss("#ui-id-2 li").item(i).Click
Exit For
End If
Next
On Error GoTo 0
End If
Application.Wait Now + TimeSerial(0, 0, 1)
.FindElementById("computeByInput").Click
Stop 'delete me later
.Quit
End With
End Sub
Public Function MatchFound(ByVal re As Object, ByVal inputString As String, ByVal pattern As String) As Boolean
With re
.Global = True
.MultiLine = True
.IgnoreCase = True
.pattern = pattern
If .test(inputString) Then
MatchFound = True
Exit Function
End If
End With
MatchFound = "False"
End Function
Related
I have a UserForm with a MultipageControl (name Controller_MultiPage).
At runtime my code adds pages to the Multipage and creates a newListView on each page.
Every ListView has:
With newListView
.MultiSelect = False
.Width = Controller_MultiPage.Width - 10
.Height = Controller_MultiPage.Height - 20
.View = lvwReport
.HideColumnHeaders = False
.ColumnHeaders.Add Text:="Signal Name", Width:=.Width / 10 * 4
.ColumnHeaders.Add Text:="Type", Width:=.Width / 10
.ColumnHeaders.Add Text:="I/O", Width:=.Width / 10
.ColumnHeaders.Add Text:="Description", Width:=.Width / 10 * 4
.CheckBoxes = True
.FullRowSelect = True
End With
then I populate the newListView with data from an XML file:
For Each node In list
With node.Attributes
Set listItem = newListView.ListItems.Add(Text:=.getNamedItem("Name").Text)
listItem.ListSubItems.Add = .getNamedItem("Type").Text
listItem.ListSubItems.Add = IIf(.getNamedItem("Input").Text = "1", "IN", "OUT")
listItem.ListSubItems.Add = .getNamedItem("Description").Text
listItem.Checked = False
End With
Next
but the checkboxes do not show. I can see the space for them in front of the first column and by clicking that space the checkbox of that particular row then appears. What I also noticed is that if I change the property
listItem.Checked = True
the behavior described above does not change, and when I click the free space in front of the first column (checkboxes space) the chsckbox that then shows up is still unchecked.
Any idea?
The problem seems to be in the behavior of the MultiPage control.
What I noticed was that if I forced the checkboxes' status (checked or unchecked) from the code, using the MultiPage_Change event, then the checkboxes show up.
So what I did was to create a class that holds the status of all checkboxes of all listviews on a single page, instantiate the Class for each ListView and store everything into a Dictionary, using the newListView.Name as Key
Then when the user changes page, the MultiPage_Change event that fires resets all the values of the checkboxes according to the Dictionary stored values.
In the Listview_N_ItemChecked event some other code updates the status of the item stored in the Dictionary.
Kind of cumbersome but it works.
the class (updated):
' Class Name = ComponentsSignalsRecord
Option Explicit
Dim Name As String
' NOTE: Signals(0) will always be empty and status(0) will always be False
Dim Signals() As String
Dim Status() As Boolean
Dim Component As String
Property Let SetComponentName(argName As String)
Component = argName
End Property
Property Get GetComponentName() As String
GetComponentName = Component
End Property
Property Get getSignalName(argIndex) As String
If argIndex >= LBound(Signals) And argIndex <= UBound(Signals) Then
getSignalName = Signals(argIndex)
Else
getSignalName = vbNullString
End If
End Property
Property Get dumpAll() As String()
dumpAll = Signals
End Property
Property Get Count() As Long
Count = UBound(Signals)
End Property
Property Get getStatus(argName As String) As Integer
' returns: -1 = Not Found; 1 = True; 0 = False
getStatus = -1
Dim i As Integer
For i = 0 To UBound(Signals)
If argName = Signals(i) Then getStatus = IIf(Status(i) = True, 1, 0): Exit For
Next
End Property
Property Let setName(argName As String)
Name = argName
End Property
Property Get getName() As String
getName = Name
End Property
Public Sub UncheckAll()
Dim i As Integer
For i = 0 To UBound(Status)
Status(i) = False
Next
End Sub
Public Sub CheckAll()
Dim i As Integer
For i = 0 To UBound(Status)
Status(i) = True
Next
End Sub
Public Sub deleteSignal(argName As String)
Dim spoolSignals() As String
Dim spoolStatus() As Boolean
Dim i As Integer
spoolSignals = Signals
spoolStatus = Status
ReDim Signals(0)
ReDim Status(0)
For i = 1 To UBound(spoolSignals)
If argName <> spoolSignals(i) Then
ReDim Preserve Signals(UBound(Signals) + 1): Signals(UBound(Signals)) = spoolSignals(i)
ReDim Preserve Status(UBound(Status) + 1): Status(UBound(Status)) = spoolStatus(i)
End If
Next
End Sub
Public Sub addSignal(argName As String, argValue As Boolean)
Dim i As Integer
For i = 0 To UBound(Signals)
If argName = Signals(i) Then GoTo bye
Next
ReDim Preserve Signals(UBound(Signals) + 1)
ReDim Preserve Status(UBound(Status) + 1)
Signals(UBound(Signals)) = argName
Status(UBound(Status)) = argValue
bye:
End Sub
Public Sub setStatus(argName As String, argValue As Boolean)
Dim i As Integer
For i = 0 To UBound(Signals)
If argName = Signals(i) Then Status(i) = argValue: Exit For
Next
End Sub
Private Sub Class_Initialize()
ReDim Signals(0)
ReDim Status(0)
End Sub
The Form relevant code. Module level:
Dim myDict As New Dictionary ' the Dictionary
Dim ComponentsSignalsList As ComponentsSignalsRecord ' the Class
for each ListView created, may be one or more for every single MultiPage page :
Set ComponentsSignalsList = New ComponentsSignalsRecord
ComponentsSignalsList.setName = newListView.name
while populating the listview(s) in a loop for each single item added:
ComponentsSignalsList.addSignal List_Item.Text, List_Item.Checked
end of each loop, add the Class instance to the Dictionary:
myDict.Add ComponentsSignalsList.getName, ComponentsSignalsList
Now when changing Page in the MultiPage widget:
Private Sub Controller_MultiPage_Change()
If isLoading Then Exit Sub 'avoid errors and undue behavior while initializing the MultiPage widget
Dim locControl As Control
Dim controlType As String: controlType = "ListView"
With Controller_MultiPage
For Each locControl In .Pages(.value).Controls
If InStr(1, TypeName(locControl), controlType) > 0 Then
Call Check_CheckBoxes(locControl)
End If
Next
End With
End Sub
Private Sub Check_CheckBoxes(argListView As listView)
If argListView.CheckBoxes = False Then Exit Sub 'some ListViews don't have checkboxes
Dim myItem As ListItem
For Each myItem In argListView.ListItems
With myItem
.Checked = myDict.Item(argListView.name).getStatus(.Text)
End With
Next
End Sub
when ticking/unticking a checkbox (note the the ItemChecked event handler is defined in another Class Public WithEvents, where the handler calls this method passing both the ListView ID and the Item object) :
Public Sub ListViewsEvents_ItemCheck(argListView As listView, argItem As MSComctlLib.ListItem)
With argItem
myDict.Item((argListView .name).setStatus argName:=.Text, argValue:=.Checked
End With
End Sub
I just found the answer to the same problem that I also had and I feel so stupid. I had the first column of the Listview set to Width = 0... and thus the checkboxes would no longer show.
I gave it a width and everithing is back to normal...
I am using VBA to scrape a website. The scraper made by me works but I want to implement 2 more functions and don't really know how to do it. This is the code:
Sub pronutrition()
Set ie = CreateObject("InternetExplorer.Application")
my_url = "https://www.myprotein.ro/"
ie.Visible = True
i = 20
LastRow = ActiveSheet.Range("A" & ActiveSheet.Rows.Count).End(xlUp).Row
Set Rng = ActiveSheet.Range("A20:A" & LastRow)
For Each cell In Rng
ie.navigate my_url
Do While ie.Busy
DoEvents
Loop
Wait 1
ie.Document.getElementsByName("search")(0).Value = cell
ie.Document.getElementsByClassName("headerSearch_button")(0).Click
Do While ie.Busy
DoEvents
Loop
Wait 2
ActiveSheet.Range("B" & i) = ie.Document.getElementsByClassName("athenaProductBlock_productName")(0).innerText + ie.Document.getElementsByClassName("athenaProductBlock_fromValue")(0).innerText
Do While ie.Busy
DoEvents
Loop
Wait 2
ActiveSheet.Range("C" & i) = ie.Document.getElementsByClassName("athenaProductBlock_productName")(1).innerText + ie.Document.getElementsByClassName("athenaProductBlock_fromValue")(1).innerText
Do While ie.Busy
DoEvents
Loop
Wait 2
ActiveSheet.Range("D" & i) = ie.Document.getElementsByClassName("athenaProductBlock_productName")(2).innerText '+ ie.Document.getElementsByClassName("athenaProductBlock_priceValue")(2).innerText
Do While ie.Busy
DoEvents
Loop
Wait 2
ActiveSheet.Range("E" & i) = ie.Document.getElementsByClassName("athenaProductBlock_productName")(3).innerText '+ ie.Document.getElementsByClassName("athenaProductBlock_priceValue")(3).innerText
Do While ie.Busy
DoEvents
Loop
Wait 2
i = i + 1
Next cell
ie.Quit
MsgBox "Done"
End Sub
First I want to search for "athenaProductBlock_fromValue" class and if it doesn't find it to search for "athenaProductBlock_priceValue", and second, if it doesn't find more than 1 or 2 products (the range is set to 4) to stop the search (right now it returns and error if it doesn't find a 2nd or a 3rd product and won't go to search the next keyword).
Any advice would be appreciated.
Thank you!
Use a helper method to extract the HTMLCollection returned by the getElementsByClassName method. You can then check if the method returned any results.
Once you get back the collection filled, it's up to you how to handle it. You can loop and fill individual cells or join the results to fill a single cell. Also, if the Count is less then 2, ignore it etc.
Private Function TryExtractElementsByClassName(ByVal ie As Object,
ByVal className As String,
ByRef objCollection As VBA.Collection) As Boolean
'if ie is null, return false
If ie Is Nothing Then Exit Function
'if elements (HTMLCollection) is null, return false
Dim elements As Object
Set elements = ie.Document.getElementsByClassName(className)
If elements Is Nothing Then Exit Function
'fill collection
Dim element As Object, idx As Long
For idx = 0 To elements.Length
Set element = elements(idx)
If Not element Is Nothing Then objCollection.Add element
Next idx
'return
TryExtractElementsByClassName = objCollection.Count > 0
End Function
To call the helper method:
Sub Test()
Dim ie As Object
Set ie = CreateObject("InternetExplorer.Application")
Dim objColl As New VBA.Collection
'search single class name
If TryExtractElementsByClassName(ie, "athenaProductBlock_priceValue", objColl) Then
'handle results stored in objColl
End If
'search multiple class names separated by a space
If TryExtractElementsByClassName(ie, "athenaProductBlock_priceValue athenaProductBlock_fromValue", objColl) Then
'handle results stored in objColl
End If
End Sub
My excel crashes when I scrape a website for information multiple times, and insert it into cell
I already included in my code set IE = Nothing and IE Quit, but it doesn't change the fact that the code returns an error after multiple iterations
My code consists of a loop-part and the actual scraping. Here is the loop:
Public Sub LooperForMMDescription()
Dim currentValue As String
Dim dataList As Variant
Dim i As Integer
Dim n As Integer
Dim FirstRow As Integer
Dim IE As Object
n = 1
Set dataList = Range("Table6")
FirstRow = Range("Table6").Row - 1
'On Error Resume Next
Set IE = Nothing
For i = 1 To UBound(dataList.Value)
If IsEmpty(dataList.Value) Then
Exit Sub
Else
currentValue = dataList(i, 1).Text
If Len(currentValue) = 0 Then
GoTo ByPass
End If
Call MM_description(currentValue, n, FirstRow, IE)
ByPass:
n = n + 1
End If
Next i
Sheets("Input").Range("F7").Select
End Sub
And this is the actual scraping:
Public Sub MM_description(currentValue As String, n As Integer, FirstRow As Integer, IE As Object)
Dim html As HTMLDocument
Dim codeLine As String
Dim startPos As Long
Dim endPost As Long
Set IE = Nothing
Set IE = CreateObject("InternetExplorer.Application")
IE.Visible = False
IE.Navigate2 (currentValue)
Do While IE.Busy
Application.Wait DateAdd("s", 1, Now)
Loop
mes = IE.document.body.innerHTML
startPos = InStr(mes, "Description") + 61
endPos = InStr(mes, "Address")
If startPos = 0 Then
Sheets("Input").Range("F" & FirstRow + n).Value = "Not Found"
Else
codeLine = Mid(mes, startPos, endPos - startPos - 229)
Sheets("Input").Range("F" & FirstRow + n).Value = codeLine
End If
IE.Quit
Set IE = Nothing
End Sub
The code runs fine for 80-90 iterations, but then it returns an error
So, this is more of a code review than an answer. The following are notes on your code and a suggested re-write.
Use Long not Integer as this reduces the risk of overflow which can happen with Integer datatype particularly when dealing with loops of rows (there are more rows than Integer can handle). Additionally, there is no performance benefit here from Integer v Long.
Camelcase local variables
firstRow
Improve readability by using worksheet variables
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1")
Use explicit sheet references not bug prone implicit Activesheet references. Using ws variable from above:
Range("Table6")
which has implicit Activesheet reference can have an explicit sheet reference
ws.Range("Table6")
dataList.value is a 2d array, as you are reading in a range from a worksheet:
For i = 1 To UBound(dataList.Value)
So, there should be a second dimension specified in your loop and it would be more efficient to read that 2d array into a variable, rather than incurring the repeated expensive i/o of going out to sheet for a value
I don't know what your table6 looks like but I suspect you are attempting to loop a specific column (likely the first)
You could then, instead, put the table into a variable and then read its first column values (excluding header) into a 1D array to loop. As you will later be writing out values to the sheet again, dimension an output array to the same dimensions as the array you are looping to store the results of your loop in
Dim arr(), table As ListObject, output()
Set table = ws.ListObjects("Table6")
arr = Application.Transpose(table.ListColumns(1).DataBodyRange.Value)
ReDim output(1 To UBound(arr))
This
If IsEmpty(dataList.Value) Then
Exit Sub
Else
is basically looking at whether the table databodyrange is empty. Assuming your are checking if there are any urls in column 1 of your table then this test is only needed
once before the loop and can be a one liner without the If Else End If
If IsEmpty(arr) Then Exit Sub
Consider renaming local variables to more useful/descriptive values: currentValue to currentUrl as this is more useful IMO.
This
If Len(currentValue) = 0 Then
GoTo ByPass
End If
is basically checking whether there is a value to pass as an url and using GoTo to handle not present. Avoid GoTo where possible as it makes code harder to read. It isn't needed here. You can use a quick vbNullString comparison, or even better Instr(url, "http") > 0 to validate the value you will be working with:
(I have switched from currentValue)
'initial code
If currentUrl <> vbNullString Then 'test
'call the sub and extract value
End If
n = n + 1 'increment....loop....rinse....repeat
Alterative validation:
If instr(currentUrl, "http") > 0 Then 'test
'call the sub and extract value
End If
n = n + 1 'increment....loop....rinse....repeat
As you already have a loop variable of i then n isn't really needed at all. Particularly in light of populating an output array at same indices.
ie is already nothing when you have Dim ie As..... You want to instantiate the object at the start
Set ie = CreateObject("InternetExplorer.Application")
Then work with that instance throughout your loop. You already include ie in your scraping sub signature, so it is expected that you will pass the same instance around:
Public Sub MM_description(currentValue As String, n As Long, firstRow As Long, ie As Object)
Add ByRef, ByVal to signature
Public Sub MM_description(ByVal currentValue As String, ByVal n As Long, ByVal firstRow As Long, ByVal ie As Object)
Remove redundant Call keyword when calling the sub and remove the () as this is a sub with params
Call MM_description(currentValue, n, firstRow, ie) > MM_description currentValue, n, firstRow, ie
As you are passing ie to the sub MM_description you don't want to then deference it and instantiate a new instance inside the called sub. So, remove
Set ie = Nothing
Set ie = CreateObject("InternetExplorer.Application")
ie.Visible = False
from inside MM_description
Inside the called sub:
Remove the () from
ie.Navigate2 (currentUrl)
So
ie.Navigate2 currentUrl
and use a proper page load wait. So replace:
Do While ie.Busy
Application.Wait DateAdd("s", 1, Now)
Loop
with
while .busy or .readystate <> 4:wend
Remove unused variables e.g. Dim html As HTMLDocument, and declare all others that are used e.g. Dim mes As String. Put Option Explicit at the top of your module to check for consistency of variable spellings and declarations.
Now, I would actually convert this sub, MM_description, into a function that returns the scraped string value, or "Not Found", and populates the output array in the same loop which calls the function.
If this is now a function the signature needs a return type specified, the call to the function needs an assignment and the () come back as there is evaluation.
output(i) = MM_description(currentUrl, n, firstRow, ie)
Finally, write out the output array to whichever range you want the output values in one go.
Worksheets("Input").Range("F1").Resize(UBound(output), 1) = Application.Transpose(output)
Many of the above changes would lead to a structure like:
Option Explicit
Public Sub LooperForMMDescription()
Dim currentUrl As String, i As Long
Dim ie As Object, ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1")
Set table = ws.ListObjects("Table6")
Dim arr(), table As ListObject, output()
arr = Application.Transpose(table.ListColumns(1).DataBodyRange.Value)
ReDim output(1 To UBound(arr))
Set ie = CreateObject("InternetExplorer.Application")
If IsEmpty(arr) Then Exit Sub
ie.Visible = True
For i = LBound(arr) To UBound(arr)
currentUrl = arr(i)
If InStr(currentUrl, "http") > 0 Then 'test
'call the sub and extract value
output(i) = MM_description(currentUrl, i, ie)
End If
Next i
ie.Quit
ThisWorkbook.Worksheets("Input").Range("F1").Resize(UBound(output), 1) = Application.Transpose(output)
End Sub
Public Function MM_description(ByVal currentUrl As String, ByVal i As Long, ByVal ie As Object) As String
Dim codeLine As String, startPos As Long, endPos As Long, mes As String
With ie
.Navigate2 currentUrl
While .Busy Or .readyState < 4: DoEvents: Wend
mes = .document.body.innerHTML
startPos = InStr(mes, "Description") + 61
endPos = InStr(mes, "Address")
If startPos = 0 Then
MM_description = "Not Found"
Else
codeLine = Mid$(mes, startPos, endPos - startPos - 229)
MM_description = codeLine
End If
End With
End Function
I am trying to check for some domains using selenium in VBA
Here's my try
Option Explicit
Sub Check_Domain()
Dim bot As New WebDriver
Dim sDomain As String
sDomain = "facebookopop.com"
bot.Start "chrome", "https://ae.godaddy.com/domainsearch/find?checkAvail=1&tmskey=&domainToCheck=" & sDomain
bot.Get "/"
Dim eleTaken As Object, eleAvailable As Object
bot.Wait 3000
On Error Resume Next
Set eleTaken = bot.FindElementByXPath("//text()[contains(.,'Domain Taken')]/ancestor::span[1]")
Set eleAvailable = bot.FindElementByXPath("//text()[contains(.,'Domain Available')]/ancestor::span[1]")
On Error GoTo 0
If Not eleTaken Is Nothing Then
Debug.Print "Not Avaialable"
ElseIf Not eleAvailable Is Nothing Then
Debug.Print "Avaialable"
Else
Debug.Print "Unknown"
End If
Stop
End Sub
The code runs slowly and at the same time it doesn't give me correct results all the time .. How can I check for the existence of an element in an easy way and avoid errors?
I don't know why the following code doesn't work
Sub Check_Domain_Advanced()
Dim bot As New WebDriver
Dim sDomain As String
Dim c As Range
Dim ele As Object
Dim t
Const MAX_WAIT_SEC As Long = 10
bot.Start "chrome"
For Each c In Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row)
If Not IsEmpty(c.Value) Then
sDomain = c.Value
bot.ExecuteScript "window.open(arguments[0])", "https://ae.godaddy.com/domainsearch/find?checkAvail=1&tmskey=&domainToCheck=" & sDomain
bot.SwitchToNextWindow
t = Timer
Do
If Timer - t > MAX_WAIT_SEC Then Exit Do
Loop While bot.FindElementsByCss("span[class='domain-name-text h2']").Count = 0
Set ele = bot.FindElementByCss("span[class='domain-name-text h2']")
If ele.IsPresent Then
If InStr(ele.Text, "available") Then
c.Offset(, 1).Value = "Avaialable"
ElseIf InStr(ele.Text, "taken") Then
c.Offset(, 1).Value = "Not Avaialable"
Else
c.Offset(, 1).Value = "Unknown"
End If
End If
End If
Next c
Stop
End Sub
I need to open each link in a new tab and check for the domain (available or taken) but I got errors as for the element (because of the page loads)
Any suggestions how to improve the code so as to work faster and to avoid errors?
Use the API which has a field for this. There is an exact match API as well as a cross sell.
Exact match
Option Explicit
Public Sub CheckDomainAvailability()
Dim json As Object, domains(), i As Long, url As String
domains = Array("google.com", "bszadfdws.com")
url = "https://find.godaddy.com/domainsapi/v1/search/exact?q=####&key=dpp_search&pc=&ptl=&itc=dpp_absol1"
With CreateObject("MSXML2.XMLHTTP")
For i = LBound(domains) To UBound(domains)
.Open "GET", Replace$(url, "####", domains(i)), False
.send
Debug.Print JsonConverter.ParseJson(.responseText)("ExactMatchDomain")("IsAvailable")
Next
End With
End Sub
Cross sell to look at related domains:
https://find.godaddy.com/domainsapi/v1/crosssell/all?sld=domainNameGoesHere&key=dpp_search&pc=&ptl=&itc=dpp_absol1
You would then need to look at the value for key CrossSellDomains instead of ExactMatchDomain
Requirements:
Download and add to your project jsonconverter.bas from here
VBE > Tools > References > Add reference to Microsoft Scripting Runtime
Selenium version:
Used timed loop and check contents of header for available.
Option Explicit
Public Sub CheckDomainAvailability()
Dim d As WebDriver, domains(), i As Long, t As Date, ele As Object
Const MAX_WAIT_SEC As Long = 10
domains = Array("google.com", "bszadfdws.com")
Set d = New ChromeDriver
With d
.Start "Chrome"
For i = LBound(domains) To UBound(domains)
.get "https://ae.godaddy.com/domainsearch/find?checkAvail=1&tmskey=&domainToCheck=" & domains(i)
t = Timer
Do
On Error Resume Next
Set ele = .FindElementByCss(".exact-header-tag")
On Error GoTo 0
If Timer - t > MAX_WAIT_SEC Then Exit Do
Loop While ele Is Nothing
If Not ele Is Nothing Then
Debug.Print domains(i) & " available = " & (InStr(LCase$(ele.text), "available") > 0)
Set ele = Nothing
End If
Next
.Quit
End With
End Sub
I have the following piece of code
Do
On Error Resume Next
.FindElementById("ContentPlaceHolder1_DropDownListl2").AsSelect.SelectByText ("txt")
On Error GoTo 0
Loop Until .FindElementById("ContentPlaceHolder1_DropDownListl2").AsSelect.SelectedOption.Text = "txt"
I have a lot of drop down lists that I deal with them with the same approach and although I used On Error Resume Next, I got errors sometimes and I have to wait a little and click Resume to resume the code execution
Can I make this as public procedure as I will use such lines a lot with other elements?
And how I can avoid the errors? and of course at the same time get my target for selecting the desired text in the drop down
Here's a snapshot of one of the errors
Based on #QHarr reply I tried to make a public procedure like that
Sub WaitElement(driver As Selenium.WebDriver, sElement As SelectElement, txt As String)
Dim t As Date
Const MAX_SEC As Long = 30
With driver
On Error Resume Next
t = Timer
Do
DoEvents
sElement.AsSelect.SelectByText txt
If Timer - t > MAX_SEC Then Exit Do
Loop Until sElement.AsSelect.SelectedOption.Text = txt
On Error GoTo 0
End With
End Sub
But when trying to use it in that way
WaitElement bot, .FindElementById("ContentPlaceHolder1_DropDownListnat"), ws.Range("B11").Value
I got 'Run-time error 13' (Type mismatch)
After applying the UDF named 'TextIsSet' I got this error
and the same problem.. if I click on Debug then Resume then wait a little, the code resumes its work
I have used such lines too but doesn't help
Do
Loop While .FindElementsById("ContentPlaceHolder1_Dschool").Count = 0
I got the same last error of not founding such an element
This can happen when an action causes a change to the DOM. The lazy way is to add a timed loop to try for that element until that error goes away or time out reached. You could also try shifting the On Error to surround the loop instead of inside the loop and then add in a time out. This is a little brutal but without a webpage to test with.
As a function call (this feels ugly and you may find webElements don't like being passed around):
Option Explicit
Public Sub test()
Const MAX_WAIT_SEC As Long = 30
'other code
If TextIsSet(dropdown, expectedText, MAX_WAIT_SEC) Then
End If
End Sub
Public Function TextIsSet(ByRef dropdown As Object, ByVal expectedText As String, ByVal MAX_WAIT_SEC As Long) As Boolean
Dim t As Date
On Error Resume Next
t = Timer
Do
DoEvents
dropdown.AsSelect.SelectByText expectedText
If Timer - t > MAX_WAIT_SEC Then Exit Do
Loop Until dropdown.AsSelect.SelectedOption.Text = expectedText
If dropdown.AsSelect.SelectedOption.Text = expectedText Then
TextIsSet = True
Else
TextIsSet = False
End If
On Error GoTo 0
End Function
I don't have a stale element test case so I just used a drop down test case:
Option Explicit
Public Sub test()
Const MAX_WAIT_SEC As Long = 30
Dim d As WebDriver, expectedText As String, dropdown As Object
'expectedText = "AL - Alabama" ''Pass Case
expectedText = "Bananaman" 'Fail Case
Set d = New ChromeDriver
With d
.get "https://tools.usps.com/zip-code-lookup.htm?byaddress"
Set dropdown = .FindElementById("tState")
'other code
If TextIsSet(dropdown, expectedText, MAX_WAIT_SEC) Then
Debug.Print "Tada"
Else
Debug.Print "Sigh"
End If
.Quit
End With
End Sub
Public Function TextIsSet(ByRef dropdown As Object, ByVal expectedText As String, ByVal MAX_WAIT_SEC As Long) As Boolean
Dim t As Date
On Error Resume Next
t = Timer
Do
DoEvents
dropdown.AsSelect.SelectByText expectedText
If Timer - t > MAX_WAIT_SEC Then Exit Do
Loop Until dropdown.AsSelect.SelectedOption.Text = expectedText
If dropdown.AsSelect.SelectedOption.Text = expectedText Then
TextIsSet = True
Else
TextIsSet = False
End If
On Error GoTo 0
End Function