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表现得更好（更快，更可靠）。

Answer 2

当我遇到类似的问题时，我发现这篇文章非常有用。这是我的解决方案：

我用过

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分钟，如果浏览器尚未就绪，则退出浏览器并退出子。

Answer 3

我知道这是一个旧帖子，但是。使用Excel VBA自动化下载网站图片的代码遇到相同的问题。某些网站不允许您使用链接下载图像文件，而无需先在浏览器中打开链接。但是当下面的代码将objBrowser.visible设置为false时，我的代码有时会挂满

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

简单的解决方法是使objBrowser.visible 我用

解决了

 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仅闪烁不到一秒钟，但它可以完成工作！

VBA挂在ie.busy和readystate检查

3 个答案: