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

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 分钟，如果浏览器未准备好，它会退出浏览器并退出 sub。

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