VBA w zawieszeniu na ie.busy i sprawdzianu w trybie readystate

Question

Próbuję pobrać dane ze strony piłkarza ze strony internetowej, aby wypełnić prywatną bazę danych. Załączam cały kod poniżej. Ta pierwsza sekcja to looper, który wywołuje drugą funkcję do wypełnienia bazy danych. Uruchomiłem ten kod w MSAccess, aby wypełnić bazę danych zeszłego lata i działało świetnie.

Teraz ja dostaję tylko kilka zespołów wypełnić zanim program zostanie zawieszony na

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

Rozglądałem niezliczone strony internetowe dotyczące tego błędu i próbował zmianę tego kodu poprzez wprowadzenie funkcji sub poczekać okres sekund lub inne prace wokół. Żadne z nich nie rozwiązuje problemu. Próbowałem również uruchomić to na wielu komputerach.

Pierwszy komputer przeszedł przez 3 zespoły (lub trzy połączenia drugiej funkcji). Drugi wolniejszy komputer przechodzi przez 5 zespołów. Obaj w końcu zawisną. Pierwszy komputer ma Internet Explorera 10, a drugi ma 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 funkcja:

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

W Parse_Team_RawSalaries, zamiast korzystania z obiektu InternetExplorer.Application, jak o użyciu MSXML2.XMLHTTP60?

Więc zamiast tego:

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 

Może spróbuj tego (dodać odniesienie do "Microsoft XML 6.0" w edytorze VBA pierwszy):

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 

ja ogólnie stwierdził, że MSXML2.XMLHTTP60 (i WinHttp.WinHttpRequest, jeśli o to chodzi) generalnie działają lepiej (szybciej i bardziej niezawodnie) niż InternetExplorer.Application.

Answer 2

Znalazłem ten post bardzo pomocny, gdy spotkałem podobny problem. Oto moje rozwiązanie:

użyłem

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

i

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 

Czasami strona jest załadowany, ale kod zatrzymuje się na DoEvents i idzie dalej i dalej i dalej. Korzystanie z tego kodu trwa tylko 1 minutę, a jeśli przeglądarka nie jest gotowa, opuszcza przeglądarkę i kończy pracę podrzędną.