web-dev-qa-db-fra.com

VBA accrochant sur ie.busy et readystate check

J'essaie de récupérer des données de joueurs de football sur un site Web pour remplir une base de données utilisée à titre privé. J'ai inclus le code complet ci-dessous. Cette première section est une boucle qui appelle la deuxième fonction pour remplir une base de données. J'ai exécuté ce code dans MSAccess pour remplir une base de données l'été dernier et cela a très bien fonctionné. 

Maintenant, il ne me reste plus que quelques équipes à remplir avant que le programme ne soit suspendu à 

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

J'ai parcouru d'innombrables sites Web concernant cette erreur et essayé de modifier ce code en mettant en place une fonction permettant d'attendre une période de secondes ou d'autres solutions de contournement. Aucune de celles-ci ne résout le problème. J'ai également essayé d'exécuter ceci sur plusieurs ordinateurs. 

Le premier ordinateur passait par 3 équipes (ou trois appels de la 2e fonction). Le deuxième ordinateur, plus lent, traverse 5 équipes. Les deux finissent par pendre. Le premier ordinateur a Internet Explorer 10 et le second 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

Deuxième fonction:

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
internet-explorervbainternet-explorer-8access-vbainternet-explorer-10
8
Doubledown

Dans Parse_Team_RawSalaries, au lieu d'utiliser l'objet InternetExplorer.Application, pourquoi ne pas utiliser MSXML2.XMLHTTP60?

Donc, au lieu de cela:

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

Essayez peut-être d'utiliser ceci (ajoutez d'abord une référence à "Microsoft XML 6.0" dans l'éditeur 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

J'ai généralement constaté que MSXML2.XMLHTTP60 (et WinHttp.WinHttpRequest, d'ailleurs) fonctionnait généralement mieux (plus vite et plus fiable) que InternetExplorer.Application.

12
wlgreg

J'ai trouvé ce post très utile lorsque j'ai rencontré un problème similaire. Voici ma solution:

J'ai utilisé 

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

et

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

Parfois, la page est chargée mais le code s'arrête sur DoEvents et continue encore et encore. L'utilisation de ce code ne dure qu'une minute et si le navigateur n'est pas prêt, il quitte le navigateur et quitte sub.

3
user2267971

Je sais que c'est un vieux post mais. J'ai eu le même problème avec mon code pour le téléchargement de photos de sites Web à l'aide de l'automatisation Excel VBA. Certains sites ne vous permettent pas de télécharger un fichier image en utilisant un lien sans d'abord ouvrir le lien dans un navigateur. Cependant, mon code commençait parfois à se bloquer lorsque objBrowser.visible était défini sur false avec le code suivant

Do Until (objBrowser.busy = False And objBrowser.readyState = 4)
        Application.Wait (Now + TimeValue("0:00:01"))
        DoEvents   'browser.readyState = 4
Loop

la solution simple était de rendre objBrowser.visible Je l'ai corrigé avec

 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 ne clignote que pendant moins d'une seconde, mais le travail est fait!

0
Rodney Sammut