VBA treo trên ie.busy và kiểm tra readystate

Question

Tôi đang cố gắng lấy một số dữ liệu cầu thủ bóng đá từ một trang web để điền vào một cơ sở dữ liệu được sử dụng riêng tư. Tôi đã bao gồm toàn bộ mã bên dưới. Phần đầu tiên này là một looper gọi hàm thứ hai để điền vào một cơ sở dữ liệu. Tôi đã chạy mã này trong MSAccess để điền vào một cơ sở dữ liệu vào mùa hè năm ngoái và nó hoạt động rất tốt.

Bây giờ tôi chỉ nhận được một vài đội bóng để lấp đầy trước khi chương trình bị treo lên tại

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

Tôi đã tìm kiếm vô số các trang web liên quan đến lỗi này và cố gắng thay đổi mã này bằng cách đưa vào chức năng phụ để chờ đợi một khoảng thời gian của giây hoặc công việc khác xung quanh. Không ai trong số đó giải quyết vấn đề. Tôi cũng đã thử chạy trên nhiều máy tính.

Máy tính đầu tiên thực hiện thông qua 3 nhóm (hoặc ba cuộc gọi của hàm thứ 2). Máy tính thứ hai chậm hơn làm cho nó thông qua 5 đội. Cả hai đều bị treo. Máy tính thứ nhất có Internet Explorer 10 và máy thứ hai có 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 

chức năng 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 

Answer 1

Trong Parse_Team_RawSalaries, thay vì sử dụng các đối tượng InternetExplorer.Application, làm thế nào về việc sử dụng MSXML2.XMLHTTP60?

Vì vậy, thay vì điều này:

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 

Có lẽ hãy thử sử dụng này (thêm một tham chiếu đến "Microsoft XML 6.0" trong VBA biên tập đầu tiên):

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 

Tôi thường thấy rằng MSXML2.XMLHTTP60 (và WinHttp.WinHttpRequest, cho vấn đề đó) thường hoạt động tốt hơn (nhanh hơn và đáng tin cậy hơn) so với InternetExplorer.Application.

Answer 2

Tôi thấy bài đăng này rất hữu ích khi gặp sự cố tương tự. Đây là giải pháp của tôi:

tôi đã sử dụng

Dim browser As SHDocVw.InternetExplorer 
Set browser = New SHDocVw.InternetExplorer 

và

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 

Đôi khi trang được tải nhưng mã dừng trên DoEvents và tiếp tục và cứ tiếp tục. Sử dụng mã này nó chỉ diễn ra trong 1 phút và nếu trình duyệt chưa sẵn sàng, nó sẽ thoát khỏi trình duyệt và thoát khỏi phụ.