Ich versuche, einige Fußballspieler-Daten von einer Website zu holen, um eine privat genutzte Datenbank zu füllen. Ich habe den gesamten Code unten eingefügt. Dieser erste Abschnitt ist ein Looper, der die zweite Funktion zum Füllen einer Datenbank aufruft. Ich habe diesen Code im letzten Sommer in MSAccess ausgeführt, um eine Datenbank zu füllen, und es hat großartig funktioniert.
Jetzt muss ich nur noch ein paar Teams füllen, bevor das Programm aufgehängt wird
While IE.Busy Or IE.ReadyState <> READYSTATE_COMPLETE: DoEvents: Wend
Ich habe unzählige Websites nach diesem Fehler durchsucht und versucht, diesen Code zu ändern, indem ich eine Unterfunktion einstelle, um einen Zeitraum von Sekunden oder andere Umgehungen zu warten. Nichts davon löst das Problem. Ich habe auch versucht, dies auf mehreren Computern auszuführen.
Der erste Computer hat es durch drei Teams geschafft (oder drei Aufrufe der zweiten Funktion). Der zweite langsamere Computer schafft es durch 5 Teams. Beide hängen schließlich. Der erste Computer verfügt über Internet Explorer 10 und der zweite über 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
Zweite Funktion:
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
Verwenden Sie in Parse_Team_RawSalaries
anstelle des InternetExplorer.Application
-Objekts MSXML2.XMLHTTP60
?
Also stattdessen:
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
Versuchen Sie dies vielleicht (fügen Sie zunächst einen Verweis auf "Microsoft XML 6.0" im VBA-Editor hinzu):
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
Ich habe im Allgemeinen festgestellt, dass MSXML2.XMLHTTP60
(und WinHttp.WinHttpRequest
für diese Angelegenheit) im Allgemeinen besser (schneller und zuverlässiger) sind als InternetExplorer.Application
.
Ich fand diesen Beitrag sehr hilfreich, wenn ich auf ein ähnliches Problem gestoßen bin. Hier ist meine Lösung:
Ich benutzte
Dim browser As SHDocVw.InternetExplorer
Set browser = New SHDocVw.InternetExplorer
und
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
Manchmal wird die Seite geladen, aber der Code wird auf DoEvents angehalten und läuft immer weiter. Mit diesem Code dauert es nur 1 Minute und wenn der Browser nicht bereit ist, beendet er den Browser und verlässt das Unterprogramm.
Ich weiß, das ist ein alter Beitrag aber. Ich hatte das gleiche Problem mit meinem Code für das Herunterladen von Website-Bildern mit Excel VBA-Automatisierung. Bei einigen Websites können Sie eine Bilddatei nicht über einen Link herunterladen, ohne den Link zuvor in einem Browser zu öffnen. Allerdings wurde mein Code manchmal aufgehängt, wenn der objBrowser.visible mit dem folgenden Code auf false gesetzt wurde
Do Until (objBrowser.busy = False And objBrowser.readyState = 4)
Application.Wait (Now + TimeValue("0:00:01"))
DoEvents 'browser.readyState = 4
Loop
die einfache Lösung bestand darin, den objBrowser.visible sichtbar zu machen, mit dem ich den Fehler behoben habe
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 blinkt nur für weniger als eine Sekunde, aber es wird erledigt!