VBA closing IE javascript popup - vba

The below code opens an instance of InternetExplorer and downloads odds. It works fine but occasionally a pop-up window appears which causes the code to not work. Any help on how to navigate the below pop-up (i.e. click 'continue to oddschecker') when the pop-up does appear?
<a class="continue beta-callout js-close-class" onclick='s_objectID="javascript:void(0)_9";return this.s_oc?this.s_oc(e):true' href="javascript:void(0)">Continue to Oddschecker</a>
Full code:
Sub Oddschecker()
Dim ie, wp As Object
Dim i As Integer
Set ie = CreateObject("InternetExplorer.Application")
ie.Visible = False
ie.Navigate "https://www.oddschecker.com/horse-racing/racing-coupon"
Do While ie.Busy
DoEvents
Loop
Do While ie.ReadyState <> 4
DoEvents
Loop
Set wp = ie.Document
'Application.ActiveSheet.UsedRange.ClearContents
Application.Worksheets("sheet1").UsedRange.ClearContents
i = 2
For Each rw In wp.getElementsByTagName("table")(0).getElementsByTagName("tr")
If rw.className = "date" Then
Worksheets("sheet1").Range("A1") = rw.innerText
ElseIf rw.className = "fixture-name" Then
i = i + 1
Worksheets("sheet1").Range("A" & i) = rw.getElementsByTagName("td")(0).innerText
i = i + 1
ElseIf rw.className = "coupons-table-row match-on" Then
For Each od In rw.getElementsByTagName("p")
If InStr(od.innerText, "(") <> 0 Then
Worksheets("sheet1").Range("A" & i) = Trim(Left(od.innerText, InStr(od.innerText, "(") - 1))
np = Trim(Right(od.innerText, Len(od.innerText) - InStr(od.innerText, "(")))
Worksheets("sheet1").Range("B" & i) = Left(np, Len(np) - 1)
i = i + 1
Else
Worksheets("sheet1").Range("A" & i) = Trim(od.innerText)
i = i + 1
End If
Next od
End If
Next rw
ie.Quit
Range("A1:B" & i).WrapText = False
Columns("A:B").EntireColumn.AutoFit
Set wp = Nothing
Set ie = Nothing
End Sub

If you wish to continue with that page (navigating to that popup page), you can try like:
Dim HTML As HTMLDocument, addcheck As Object
While IE.Busy = True Or IE.readyState < 4: DoEvents: Wend ''(You can write it the way you feel comfortable)
Set HTML = IE.document ''place this line after the prevous line
Set addcheck = HTML.querySelector("#promo-modal a.continue")
If Not addcheck Is Nothing Then
addcheck.Click
End If
But, that is not a good idea cause it will lead you to some page where you might need to do some activity to get back on this data ridden page.
I suppose you should get rid of that popup blocker by ticking the cross button located on the top right area and continue to do what you are doing:
Dim HTML As HTMLDocument, addcheck As Object
While IE.Busy = True Or IE.readyState < 4: DoEvents: Wend ''(You can write it the way you feel comfortable)
Set HTML = IE.document ''place this line after the prevous line
Set addcheck = HTML.querySelector("#promo-modal span[title='Close")
If Not addcheck Is Nothing Then
addcheck.Click
End If
If I didn't understand what your intention was, do let me know. Thanks.

Related

Using VBA to click a link

I'm trying next to click a link to view information on a page using VBA to then move on to edit that information with VBA, But trying to figure out how to write the code for it as the ID information changes with each search,
Any ideas on this?
I've looked around and can't seem to understand how to get VBA to pick this line up as the (ID=) and it isn't joined to the same ID as I'm searching for.
There is also serval references for
This is the line of code.
View
This is my current code to do the search for it. Without clicking on the view section yet.
Sub Test()
Dim ie As Object
Dim form As Variant
Dim button As Variant
Dim LR As Integer
Dim var As String
LR = Cells(Rows.Count, 1).End(xlUp).Row
For x = 2 To LR
var = Cells(x, 1).Value
Set ie = CreateObject("internetexplorer.application")
ie.Visible = True
With ie
.Visible = True
.navigate "*******"
While Not .readyState = READYSTATE_COMPLETE
Wend
End With
'Wait some to time for loading the page
While ie.Busy
DoEvents
Wend
Application.Wait (Now + TimeValue("0:00:02"))
ie.document.getElementById("quicksearch").Value = var
'code to click the button
Set form = ie.document.getElementsByTagName("form")
Application.Wait (Now + TimeValue("0:00:02"))
Set button = form(0).onsubmit
form(0).submit
'wait for page to load
While ie.Busy
DoEvents
Wend
Next x
End Sub
Edited
I've added in the code I think it should be following that link and a bit of tinkering to get it to not error with compiler errors :D, All seems to work but when it get's to the line to click the link it doesn't fail but doesn't even click it. It will then move on to the next one in the list in the spreed sheet, Which is expected.
Following it through with the debugger that shows nothing erroring or failing which is what I expect it to do if the code was wrong or link,
Any help, please ?
This is the code now
Sub Test1()
Dim ie As Object
Dim form As Variant
Dim button As Variant
Dim LR As Integer
Dim var As String
LR = Cells(Rows.Count, 1).End(xlUp).Row
For x = 2 To LR
var = Cells(x, 1).Value
Set ie = CreateObject("internetexplorer.application")
ie.Visible = True
Dim a
Dim linkhref
linkhref = "/?do_Action=ViewEntity&Entity_ID"
With ie
.Visible = True
.navigate "*******"
While Not .readyState = READYSTATE_COMPLETE
Wend
End With
'Wait some to time for loading the page
While ie.Busy
DoEvents
Wend
Application.Wait (Now + TimeValue("0:00:02"))
ie.document.getElementById("quicksearchbox").Value = var
'code to click the button
Set form = ie.document.getElementsByTagName("form")
Application.Wait (Now + TimeValue("0:00:02"))
Set button = form(0).onsubmit
form(0).submit
'wait for page to load
While ie.Busy
DoEvents
Wend
Application.Wait (Now + TimeValue("0:00:02"))
For Each a In ie.document.getElementsByTagName("a")
If (a.getAttribute("href")) = ("/?do_Action=ViewEntity&Entity_ID=") Then
a.Click
Exit For
Application.Wait (Now + TimeValue("0:00:02"))
While ie.Busy
DoEvents
Wend
End If
Next
Next x
End Sub
This is a copy of the code around the buttons,
This is the code surrounding the buttons,
View
Decom
Log</td>
Thank you.
Use a For to check every <a> tag element and make sure you click the right one. It's true your ID changes, but rest of string is constant, so that's 1 factor. Also, it looks like you always will click where it says View so that's another constant.
With both options, we can develop a simple For..Next that will check every <a> element and will check if those 2 options requirements are fulfilled:
For Each a In ie.document.getElementsByTagName("a")
If Left(a.href, 37) = "/?do_Action=ViewEntity&Entity_ID=" And a.innerText = "View" Then
a.Click
Exit For
Next a
Try it and let's see if this works for you.
If the element href is something like "/?do_Action=ViewEntity&Entity_ID=14287", this if statement is never going to evaluate to True:
(a.getAttribute("href")) = ("/?do_Action=ViewEntity&Entity_ID=")
So the element will never be clicked.
If you know the Entity_ID you want to click you can do:
Dim Entity_ID as Integer
Entity_ID = 14287
If (a.getAttribute("href")) = "/?do_Action=ViewEntity&Entity_ID=" & Cstr(myID) Then a.click
Otherwise just check if the element href contains that url:
If InStr(1, a.getAttribute("href"), linkhref) > 0 Then a.click
EDIT
Ok, using the HTML you posted I am able to access the specified a tag that you requested, by doing this
For Each ele In ie.document.getElementById("searchresults").getElementsByTagName("a")
If InStr(1, ele.href, "do_Action=ViewEntity") > 0 Then
MsgBox "The button is found!"
End If
Next

How to wait for the page to load after click

Below is the code for simple IE automation which simply inputs order number like 1413105088 and postal code which is always 78759 and clicks on submit button and then from the result page it gets the tracking number like 017136295201034
and puts them in column C.
It works as expected but as IE is not so reliable and slow I was wondering if there is a faster way to do this process and if not can I make it atleast reliable so that it doesn't fails after click on the submit button, meaning the
Do While IE.Busy Or IE.ReadyState <> 4
DoEvents
Loop
after
.document.getElementsByClassName("button_text")(3).Click
fails as it doesn't really checks if the ie page has finished loading.
I am asking this as I have to do this for 100s of such request. Thanks in advance.
Full code:
Sub test()
Dim urL As String, orderNum As String
Dim trackingNum, prodDetail, cet
Dim i As Long, fI As Long
Dim IE
urL = "https://fisher-price.mattel.com/webapp/wcs/stores/servlet/OrderStatusGuestView?catalogId=10101&langId=-1&storeId=10151&krypto=prThs8zyeWG0bkF9ajSr%2FCnzmv1TKodtTEw0EdXtC7NjEmfD3cb6Z75umdkcXCiEPFxvkd0TfHkOswm3ZcMp8sbrU2doZFa6TxVbI%2BW1Lzk%3D"
fI = MAIN.Range("B" & Rows.Count).End(xlUp).Row
Set IE = CreateObject("InternetExplorer.Application")
With IE
.Visible = True
For i = 2 To fI
orderNum = Trim(MAIN.Range("B" & i).Value) 'Sample ordernum = 1413105088
If orderNum <> "" Then
.navigate urL
Do While IE.Busy Or IE.ReadyState <> 4
DoEvents
Loop
.document.getelementbyid("orderNumber").Value = orderNum
.document.getelementbyid("postalCode").Value = 78759
.document.getElementsByClassName("button_text")(3).Click
Application.Wait Now + TimeValue("00:00:02")
Do While IE.Busy Or IE.ReadyState <> 4
DoEvents
Loop
prodDetail = .document.getElementsByClassName("productDetails")(0).innerText
If InStr(prodDetail, "Tracking :") > 0 Then
cet = Split(prodDetail, "Tracking :")
trackingNum = Trim(cet(1))
MAIN.Range("C" & i).Value = trackingNum
Else
MAIN.Range("C" & i).Value = "N/A"
End If
End If
Next i
End With
IE.Quit
Set IE = Nothing
End Sub
Even i faced this problem where the Do While... Loop did not load properly so i used the below code
x = 0
Do until x = 1
if IsObject(.document.getelementbyid("orderNumber")) Then
.document.getelementbyid("orderNumber").Value = orderNum
.document.getelementbyid("postalCode").Value = 78759
.document.getElementsByClassName("button_text")(3).Click
x = 1
Else
Application.Wait Now + TimeValue("00:00:02")
End if
Loop
Working:
Since x=0 it will go insde the Loop and since the IsObject(.document.getelementbyid("orderNumber")) was not found so it will wait for two second and loop will continue till it find the ordernumber or else it will make the value as x=1 and exit the loop.
Caution: if your code does not work then this code will run till eternity. For which you can set the limit the loop.

Refresh or reload Internet Explorer object in Excel VBA

I'm working on a way to fill in online forms using data from an Excel Spreadsheet. I'm using the VBA Modules in Excel to do so.
The steps are as follows:
1) Navigate to page
2) Fill in details
3) Click "Continue" to continue to the next page
4) Fill in more details
5) Click "Save" to save the page
Here is the code:
Sub FillInternetForm()
'Header Start
Dim IE As Object
Dim ROW As Integer
Dim MAXROW As Integer
Set IE = CreateObject("InternetExplorer.Application")
MAXROW = 3
ROW = 2
'Header End
'Step 1 Navigate to the page
IE.Navigate *PAGE_1_URL*
IE.Visible = True
While IE.Busy Or IE.ReadyState <> 4
DoEvents
Wend
'Step 1 Ends
'Step 2&3 Fill in the details and click "continue"
IE.Document.ALL("ctl00_PageContent_PAYDPaymentMode").Value = "18"
IE.Document.ALL("ctl00_PageContent_PAYDPaymentDate").Value = Cells(ROW, 1).Value
IE.Document.ALL("ctl00_PageContent_PAYDBusinessUnit").Value = "104"
IE.Document.ALL("ctl00_PageContent_PAYDAmountPaid").Value = Cells(ROW, 2).Value
IE.Document.ALL("ctl00_PageContent_ContinueButton__Button").Click
While IE.Busy Or IE.ReadyState <> 4
DoEvents
Wend
'Step 2&3 Ends (IE moved to page 2)
'Step 4&5 Fill in more details and click "Save"
IE.Document.ALL("ctl00_PageContent_BankChequeOrOtherRef").Value = ThisWorkbook.Sheets("sheet1").Cells(ROW, 3).Value
IE.Document.ALL("ctl00_PageContent_PAYDRemarks").Value = ThisWorkbook.Sheets("sheet1").Cells(ROW, 4).Value
IE.Document.ALL("ctl00_PageContent_SaveButton__Button").Click
'Step 4&5 Ends
End Sub
I did step 1 to 3 fine. However, when it comes to step 4, I get an error. The error is: Runtime error 424 Object required. I am aware that this means that the Module is unable to locate the elements in step 4.
The error is at exactly:
IE.Document.ALL("ctl00_PageContent_BankChequeOrOtherRef").Value = ThisWorkbook.Sheets("sheet1").Cells(ROW, 3).Value
Before the process has to be terminated.
To debug whether the code in step 4 has any problem, I took it out and ran it separately. I took the entire section of Step4&5 and header out and make it navigate to the 2nd page instead.
Like so:
Sub FillInternetForm()
Dim IE As Object
Dim ROW As Integer
Dim MAXROW As Integer
Set IE = CreateObject("InternetExplorer.Application")
MAXROW = 3
ROW = 2
IE.Navigate *PAGE_2_URL*
IE.Visible = True
While IE.Busy Or IE.ReadyState <> 4
DoEvents 'wait until IE is done loading page.
Wend
IE.Document.ALL("ctl00_PageContent_BankChequeOrOtherRef").Value = ThisWorkbook.Sheets("sheet1").Cells(ROW, 3).Value
IE.Document.ALL("ctl00_PageContent_PAYDRemarks").Value = ThisWorkbook.Sheets("sheet1").Cells(ROW, 4).Value
IE.Document.ALL("ctl00_PageContent_SaveButton__Button").Click
End Sub
And it worked.
I have no idea what is the problem. I'm guessing that all the elementID was loaded at the start or something and that the page 2 IDs were not loaded?
Does anyone know the source or solution to this problem? Thank you.
P.S. All names element ID are copied and pasted from the source code of the webform and should be correct.
Edit:
I have updated the issue in a comment below.
Edit2: Tried the exact same code on a win10 machine with excel 2016. Code worked perfectly. Thanks for all the help provided.
Please give this a try... (not tested)
Sub FillInternetForm()
'Header Start
Dim IE As Object
Dim Doc As Object
Dim ROW As Integer
Dim MAXROW As Integer
Dim ContinueButton As Object
Dim SaveButton As Object
Set IE = CreateObject("InternetExplorer.Application")
MAXROW = 3
ROW = 2
'Header End
'Step 1 Navigate to the page
IE.Navigate PAGE_1_URL
IE.Visible = True
While IE.Busy Or IE.ReadyState <> 4 Or ContinueButton Is Nothing
DoEvents
Set Doc = IE.document
Set ContinueButton = Doc.ALL("ctl00_PageContent_ContinueButton__Button")
Wend
'Step 1 Ends
'Step 2&3 Fill in the details and click "continue"
Doc.ALL("ctl00_PageContent_PAYDPaymentMode").Value = "18"
Doc.ALL("ctl00_PageContent_PAYDPaymentDate").Value = Cells(ROW, 1).Value
Doc.ALL("ctl00_PageContent_PAYDBusinessUnit").Value = "104"
Doc.ALL("ctl00_PageContent_PAYDAmountPaid").Value = Cells(ROW, 2).Value
ContinueButton.Click
While IE.Busy Or IE.ReadyState <> 4 Or SaveButton Is Nothing
DoEvents
Set Doc = IE.document
Set SaveButton = Doc.ALL("ctl00_PageContent_SaveButton__Button")
Wend
'Step 2&3 Ends (IE moved to page 2)
'Step 4&5 Fill in more details and click "Save"
Doc.ALL("ctl00_PageContent_BankChequeOrOtherRef").Value = ThisWorkbook.Sheets("sheet1").Cells(ROW, 3).Value
Doc.ALL("ctl00_PageContent_PAYDRemarks").Value = ThisWorkbook.Sheets("sheet1").Cells(ROW, 4).Value
SaveButton.Click
'Step 4&5 Ends
End Sub
Updated the code to:
Sub FillInternetForm()
'Header Start
Dim IE As Object
Dim DOC As Object
Dim ROW As Integer
Dim MAXROW As Integer
Dim SAVEBUTTON As Object
Dim COUNTER As Integer
Set IE = CreateObject("InternetExplorer.Application")
Set SAVEBUTTON = Nothing
MAXROW = 3
ROW = 2
COUNTER = 0
'Header End
'Step 1 Navigate to the page
IE.Navigate "*WEBSITE*"
IE.Visible = True
While IE.Busy Or IE.ReadyState <> 4
DoEvents
Wend
'Step 1 Ends
Set DOC = IE.Document
'Step 2&3 Fill in the details and click "continue"
DOC.ALL("ctl00_PageContent_PAYDPaymentMode").Value = "18"
DOC.ALL("ctl00_PageContent_PAYDPaymentDate").Value = Cells(ROW, 1).Value
DOC.ALL("ctl00_PageContent_PAYDBusinessUnit").Value = "104"
DOC.ALL("ctl00_PageContent_PAYDAmountPaid").Value = Cells(ROW, 2).Value
DOC.ALL("ctl00_PageContent_ContinueButton__Button").Click
'Step 2&3 Ends (IE moved to page 2)
While IE.Busy Or IE.ReadyState <> 4 Or SAVEBUTTON Is Nothing
DoEvents
If Not IE.Busy Or IE.ReadyState = 4 Then
IE.Refresh
End If
Set DOC = IE.Document
On Error Resume Next
Set SAVEBUTTON = DOC.ALL("ctl00_PageContent_SaveButton__Button")
COUNTER = COUNTER + 1
Wend
'Step 4&5 Fill in more details and click "Save"
DOC.ALL("ctl00_PageContent_BankChequeOrOtherRef").Value = ThisWorkbook.Sheets("sheet1").Cells(ROW, 3).Value
DOC.ALL("ctl00_PageContent_PAYDRemarks").Value = ThisWorkbook.Sheets("sheet1").Cells(ROW, 4).Value
DOC.ALL("ctl00_PageContent_SaveButton__Button").Click
'Step 4&5 Ends
End Sub
Found out that this snippet is not refreshing the page even though it is supposed to.
If Not IE.Busy Or IE.ReadyState = 4 Then
IE.Refresh
End If
Is it possible that the object is dropped halfway?
Occasionally the code works when visibility of IE is turned off, but it works like once every hour or something before the exact same error pops up.
The page I am accessing seems to use ASPX and generates the page base on a database, no idea if this will help.
Edit: Tried the exact same code on a win10 machine with excel 2016. Code worked perfectly.

Webbrowser control in userform: how to wait for page to initialize

Task: using Excel VBA to navigate to a website, log in and go to an input page.
On that page, sequentially enter a series of values stored in a column in Sheet1.
What I've done so far:
I create a webbrowser control and navigate to the website and stop.
Then click on a button on Sheet1 with the macros that will do the inputting, stored in a module.
What's happening:
The control comes up nicely and navigates to the intended site. (this is the userform code)
Click on the button and it gets the userid and password from the spreadsheet, inputs them, clicks on the login button and all is well.
However, the next statement is:
Set inputfield = WebBrowser.objWebBrowser.Document.getElementById("ctl02_ctl03_ddlBus")
and inputfield comes up empty.
If I stop execution and step through it, it'll work.
I've tried Application.Wait; For x = 1 to 5000000; On Error Goto/Resume and keep trying, but nothings works.
I've also tried .NavigateComplete, .DocumentCompleted, as well as others, but I get errors saying member is not supported.
I am at my wits end - I'm just so close!! So far, I've spent more time on this that it will ever save, but now it's personal! Thanks for your help.
This is borrowed code from another site that initializes the control.
Private Sub UserForm_Initialize()
Dim a, c As Integer
With Me
.StartUpPosition = 0
.Top = 150
.Left = -700
End With
With Me.objWebBrowser
.Navigate2 "http://www.schoolbuscity.com/Mapnetweb_47/login.aspx"
.Visible = True
End With
End Sub
Private Sub GetSheets()
'this is my code
Dim inputfield As Object
Dim SendText As String
Dim NumberOfRoutes, r, errCount As Integer
errCount = 0
NumberOfRoutes = Range("NumberOfRoutes")
ReDim RouteNumbers(NumberOfRoutes) As String
For r = 1 To NumberOfRoutes
RouteNumbers(r) = Cells(r, 1).Value
Next r
' Sheets("Sheet1").Select
Range(Cells(5, 2), Cells(6, 2)).ClearContents ' this indicates success for the chosen cells
SendText = Range("userid").Value
Set inputfield = WebBrowser.objWebBrowser.Document.getElementById("Login1_UserName")
inputfield.Value = SendText
SendText = Range("password").Value
Set inputfield = WebBrowser.objWebBrowser.Document.getElementById("Login1_Password")
inputfield.Value = SendText
Set inputfield = WebBrowser.objWebBrowser.Document.getElementById("Login1_Login")
Application.Wait (Now + TimeValue("0:00:01"))
inputfield.Click
Application.Wait (Now + TimeValue("0:00:01")) ' I've tried waiting for up to 10 seconds
Set inputfield = Nothing
On Error GoTo TryAgain
For r = 5 To 6 'NumberOfRoutes ' just want to use 2 loops for testing
' this is where is fails, I believe, because the page is not initialized
' but if waiting is not the answer, then what is?
Set inputfield = WebBrowser.objWebBrowser.Document.getElementById("ctl02_ctl03_ddlBus")
inputfield.Value = RouteNumbers(r)
Set inputfield = WebBrowser.objWebBrowser.Document.getElementById("ctl02_ctl03_btnGo")
inputfield.Click
Application.Wait (Now + TimeValue("0:00:01"))
Cells(r, 2).Value = "Sent"
' WebBrowser.objWebBrowser.Document.Print
WebBrowser.objWebBrowser.GoBack
Next r
GoTo EndIt
TryAgain:
Set inputfield = Nothing
Set inputfield = WebBrowser.objWebBrowser.Document.getElementById("ctl02_ctl03_ddlBus")
errCount = errCount + 1
If errCount > 5 Then GoTo EndIt
Resume
EndIt:
If errCount > 0 Then
MsgBox "errCount= " + CStr(errCount)
Else
MsgBox "Did it"
End If
End Sub
This is how to waitbin vbscript.
Set ie = CreateObject("InternetExplorer.Application")
ie.Visible = 0
'must navigate to a local file to avoid security prompts
ie.Navigate2 "C:\Users\User\Desktop\Filter.html"
Do
wscript.sleep 100
Loop until ie.document.readystate = "complete"
examples in VBA:
Private Sub UserForm_Initialize()
Set ie = Me.WebBrowser1
ie.Navigate2 "about:blank"
Do Until ie.ReadyState = READYSTATE_COMPLETE
DoEvents
Loop
Set ie = Nothing
End Sub
Private Sub Conectar_Click()
Dim ie As Object
Set ie = Me.WebBrowser1
ie.Navigate2 "http://www.mytest.com"
Do Until ie.ReadyState = READYSTATE_COMPLETE
DoEvents
Loop
'different alternatives
'Dim inputfield As Object
'Set inputfield = ie.Document.getElementById("Login_tbLogin")
'inputfield.Value = "mylogin"
'Set inputfield = Nothing
'ie.Document.getElementById("Login_tbLogin").Value = "mylogin"
'ie.Document.All("Login_tbLogin").Focus
'ie.Document.All("Login_tbLogin").Value = "mylogin"
ie.Document.All.Item("Login_tbLogin").Value = "mylogin"
Set ie = Nothing
End Sub

VBA hanging on ie.busy and readystate check

I am trying to grab some football player data from a website to fill a privately used database. I've included the entire code below. This first section is a looper that calls the second function to fill a database. I've run this code in MSAccess to fill a database last summer and it worked great.
Now I am only getting a few teams to fill before the program gets hung up at
While IE.Busy Or IE.ReadyState <> READYSTATE_COMPLETE: DoEvents: Wend
I've searched countless websites regarding this error and tried changing this code by putting in sub function to wait a period of seconds or other work-arounds. None of those solve the issue. I've also tried running this on multiple computers.
The first computer made it through 3 teams (or three calls of the 2nd function). The second slower computer makes it through 5 teams. Both eventually hang. The 1st computer has Internet Explorer 10 and the second has IE8.
Sub Parse_NFL_RawSalaries()
Status ("Importing NFL Salary Information.")
Dim mydb As Database
Dim teamdata As DAO.Recordset
Dim i As Integer
Dim j As Double
Set mydb = CurrentDb()
Set teamdata = mydb.OpenRecordset("TEAM")
i = 1
With teamdata
Do Until .EOF
Call Parse_Team_RawSalaries(teamdata![RotoworldTeam])
.MoveNext
i = i + 1
j = i / 32
Status("Importing NFL Salary Information. " & Str(Round(j * 100, 0)) & "% done")
Loop
End With
teamdata.Close ' reset variables
Set teamdata = Nothing
Set mydb = Nothing
Status ("") 'resets the status bar
End Sub
Second function:
Function Parse_Team_RawSalaries(Team As String)
Dim mydb As Database
Dim rst As DAO.Recordset
Dim IE As InternetExplorer
Dim HTMLdoc As HTMLDocument
Dim TABLEelements As IHTMLElementCollection
Dim TRelements As IHTMLElementCollection
Dim TDelements As IHTMLElementCollection
Dim TABLEelement As Object
Dim TRelement As Object
Dim TDelement As HTMLTableCell
Dim c As Long
' open the table
Set mydb = CurrentDb()
Set rst = mydb.OpenRecordset("TempSalary")
Set IE = CreateObject("InternetExplorer.Application")
IE.Visible = False
IE.navigate "http://www.rotoworld.com/teams/contracts/nfl/" & Team
While IE.Busy Or IE.ReadyState <> READYSTATE_COMPLETE: DoEvents: Wend
Set HTMLdoc = IE.Document
Set TABLEelements = HTMLdoc.getElementsByTagName("Table")
For Each TABLEelement In TABLEelements
If TABLEelement.id = "cp1_tblContracts" Then
Set TRelements = TABLEelement.getElementsByTagName("TR")
For Each TRelement In TRelements
If TRelement.className <> "columnnames" Then
rst.AddNew
rst![Team] = Team
c = 0
Set TDelements = TRelement.getElementsByTagName("TD")
For Each TDelement In TDelements
Select Case c
Case 0
rst![Player] = Trim(TDelement.innerText)
Case 1
rst![position] = Trim(TDelement.innerText)
Case 2
rst![ContractTerms] = Trim(TDelement.innerText)
End Select
c = c + 1
Next TDelement
rst.Update
End If
Next TRelement
End If
Next TABLEelement
' reset variables
rst.Close
Set rst = Nothing
Set mydb = Nothing
IE.Quit
End Function
In Parse_Team_RawSalaries, instead of using the InternetExplorer.Application object, how about using MSXML2.XMLHTTP60?
So, instead of this:
Set IE = CreateObject("InternetExplorer.Application")
IE.Visible = False
IE.navigate "http://www.rotoworld.com/teams/contracts/nfl/" & Team
While IE.Busy Or IE.ReadyState <> READYSTATE_COMPLETE: DoEvents: Wend
Set HTMLdoc = IE.Document
Maybe try using this (add a reference to "Microsoft XML 6.0" in VBA Editor first):
Dim IE As MSXML2.XMLHTTP60
Set IE = New MSXML2.XMLHTTP60
IE.Open "GET", "http://www.rotoworld.com/teams/contracts/nfl/" & Team, False
IE.send
While IE.ReadyState <> 4
DoEvents
Wend
Dim HTMLDoc As MSHTML.HTMLDocument
Dim HTMLBody As MSHTML.htmlBody
Set HTMLDoc = New MSHTML.HTMLDocument
Set HTMLBody = HTMLDoc.body
HTMLBody.innerHTML = IE.responseText
I've generally found that MSXML2.XMLHTTP60 (and WinHttp.WinHttpRequest, for that matter) generally perform better (faster and more reliable) than InternetExplorer.Application.
I've found this post very helpful when I encountered similiar problem. Here is my solution:
I used
Dim browser As SHDocVw.InternetExplorer
Set browser = New SHDocVw.InternetExplorer
and
cTime = Now + TimeValue("00:01:00")
Do Until (browser.readyState = 4 And Not browser.Busy)
If Now < cTime Then
DoEvents
Else
browser.Quit
Set browser = Nothing
MsgBox "Error"
Exit Sub
End If
Loop
Sometimes page is loaded but code stops on DoEvents and goes on and on and on. Using this code it goes on only for 1 minute and if browser is not ready it quits the browser and exits sub.
I know this is a old post but. I have had the same problem with my code for downloading web site pictures using Excel VBA automation. Some sites wont let you download a image file using a link without first opening the link in a browser. However my code was getting hung up sometimes with when the objBrowser.visible was set to false with the folowing code
Do Until (objBrowser.busy = False And objBrowser.readyState = 4)
Application.Wait (Now + TimeValue("0:00:01"))
DoEvents 'browser.readyState = 4
Loop
the simple fix was to make the objBrowser.visible
I fixed it with
Dim Passes As Integer: Passes = 0
Do Until (objBrowser.busy = False And objBrowser.readyState = 4)
Passes = Passes + 1 'count loops
Application.Wait (Now + TimeValue("0:00:01"))
DoEvents
If Passes > 5 Then
'set size browser cannot set it smaller than 400
objBrowser.Width = 400 'set size
objBrowser.Height = 400
Label8.Caption = Passes 'display loop count
' position browser "you cannot move it off the screen" ready state wont change
objBrowser.Left = UserForm2.Left + UserForm2.Width
objBrowser.Top = UserForm2.Top + UserForm2.Height
objBrowser.Visible = True
DoEvents
objBrowser.Visible = False
End If
Loop
objBrowser only flashes for less than a second but it gets the job done!