VBA掛在ie.busy和readystate檢查

我想從一個網站抓取一些足球運動員數據來填充一個私人使用的數據庫。我已經包含了下面的整個代碼。第一部分是調用第二個函數來填充數據庫的活套。我已經在MSAccess中運行這個代碼，去年夏天填充了一個數據庫，它運行得非常好。VBA掛在ie.busy和readystate檢查

現在我只得到了幾支球隊，以填補該計劃被在

 While IE.Busy Or IE.ReadyState <> READYSTATE_COMPLETE: DoEvents: Wend

掛了之前我已經搜索關於此錯誤的無數的網站，並試圖通過把在子功能等待一個改變這種代碼幾秒鐘或其他工作週期。這些都不能解決問題。我也試過在多臺電腦上運行。

第一臺電腦通過3支隊伍（或第二個功能的三個呼叫）。第二臺速度較慢的電腦通過5支隊伍。兩個最終都會掛起第一臺電腦有Internet Explorer 10，第二臺電腦有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 

    ' reset variables 
    teamdata.Close 
    Set teamdata = Nothing 
    Set mydb = Nothing 

    Status ("")     'resets the status bar 

End Sub

Seconnd功能：

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

來源

2013-07-05 exballer

如果'IE.Quit'設法有效關閉所有IE應用程序，則檢入系統應用程序管理器。您可以嘗試只打開一個IE應用程序並將其作爲參數傳遞給您的函數。以我的經驗打開IE是耗時的過程... –

在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

也許嘗試使用這個（添加引用「微軟XML 6.0」在VBA編輯在前）：

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執行更好（更快且更可靠）。

來源

2013-07-05 05:25:58 wlgreg

令人難以置信 - 完全再次作品！謝謝你太多了。這爲我節省了很多很多時間。只是最後一個問題 - 我如何處理第二個函數結束時的IE.Quit？跑步時發生錯誤，我想知道我是否需要一些可比較的東西？ – exballer

您可以將'IE.Quit'更改爲'Set IE = Nothing'。很高興幫助！ – wlgreg

，因爲有些網頁在JavaScript中放置了很多重要的內容以防止人們洗刷。 MSXML2.XMLHTTP60是否支持運行js？ – chantisnake

我發現這篇文章非常有幫助，當我遇到類似的問題。這裏是我的解決方案：

我用

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分鐘，如果瀏覽器沒有準備好，它將退出瀏覽器並退出子菜單。

來源

2014-03-01 11:25:40 user2267971

VBA掛在ie.busy和readystate檢查

回答

相關問題