VBA挂在ie.busy和readystate检查

Question

我试图从网站上获取一些足球运动员数据来填补私人使用的数据库.我已经在下面提供了整个代码.第一部分是一个调用第二个函数来填充数据库的循环器.去年夏天我在MSAccess中运行此代码来填充数据库并且效果很好.

现在我只是在程序被挂起之前让几个团队填补

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


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

  Status ("")                  'resets the status bar
End Sub

第二功能:

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

在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.