私はWebサイトからフットボール選手のデータを取得して、個人的に使用するデータベースに入力しようとしています。以下のコード全体を含めました。この最初のセクションは、データベースにデータを入力する2番目の関数を呼び出すルーパーです。私はこのコードをMSAccessで実行して、昨年の夏にデータベースにデータを入力しました。
現在、プログラムがハングアップする前に、いくつかのチームのみに情報を提供しています
While IE.Busy Or IE.ReadyState <> READYSTATE_COMPLETE: DoEvents: Wend
私はこのエラーに関して無数のウェブサイトを検索し、サブ関数を入れて数秒間待つか、または他の回避策によってこのコードを変更しようとしました。それらのどれも問題を解決しません。これを複数のコンピューターで実行してみました。
最初のコンピューターは3つのチーム(または2番目の関数の3つの呼び出し)を通過しました。 2番目に遅いコンピューターは、5つのチームを通過します。どちらも最終的にはハングします。最初のコンピューターにはInternet Explorer 10があり、2番目のコンピューターには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
2番目の機能:
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
Parse_Team_RawSalaries
では、InternetExplorer.Application
オブジェクトを使用する代わりに、MSXML2.XMLHTTP60
を使用するのはどうですか?
したがって、これの代わりに:
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
多分これを使ってみてください(最初にVBAエディターで「Microsoft XML 6.0」への参照を追加してください):
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
一般に、MSXML2.XMLHTTP60
(およびWinHttp.WinHttpRequest
)は、InternetExplorer.Application
よりも一般的にパフォーマンスが高い(高速で信頼性が高い)ことがわかりました。
同様の問題が発生したときに、この投稿は非常に役立ちました。これが私の解決策です:
使った
Dim browser As SHDocVw.InternetExplorer
Set browser = New SHDocVw.InternetExplorer
そして
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
時々ページはロードされますが、コードはDoEventsで停止し、何度も繰り返します。このコードを使用すると、1分間しか実行されず、ブラウザーの準備ができていない場合はブラウザーを終了してsubを終了します。
これは古い記事ですが。 Excel VBAオートメーションを使用してWebサイトの画像をダウンロードするためのコードにも同じ問題がありました。一部のサイトでは、最初にブラウザーでリンクを開かないと、リンクを使用して画像ファイルをダウンロードできません。ただし、次のコードでobjBrowser.visibleがfalseに設定されていると、コードがハングアップすることがありました。
Do Until (objBrowser.busy = False And objBrowser.readyState = 4)
Application.Wait (Now + TimeValue("0:00:01"))
DoEvents 'browser.readyState = 4
Loop
単純な修正は、objBrowser.visibleを作成することでした。
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は1秒未満しか点滅しませんが、ジョブが完了します。