VBA висит на ie.busy и готовность проверить

Я пытаюсь получить данные о некоторых футболистах с веб-сайта, чтобы заполнить личную базу данных. Я включил весь код ниже. Этот первый раздел представляет собой петлитель, который вызывает вторую функцию для заполнения базы данных. Я запустил этот код в MSAccess для заполнения базы данных прошлым летом, и он отлично работал.

Теперь у меня есть всего несколько команд для заполнения, прежде чем программа зависнет в

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

Я искал бесчисленное количество веб-сайтов об этой ошибке и попытался изменить этот код, добавив подфункцию для ожидания в течение нескольких секунд или других обходных путей. Никто из них не решает проблему. Я также попытался запустить это на нескольких компьютерах.

Первый компьютер сделал это через 3 команды (или три вызова 2-й функции). Второй медленный компьютер делает это через 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

  ' reset variables
  teamdata.Close
  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
Источник

3 ответа

Решение

В 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

Возможно, попробуйте использовать это (сначала добавьте ссылку на "Microsoft XML 6.0" в VBA Editor):

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,

Источник

Я нашел этот пост очень полезным, когда столкнулся с похожей проблемой. Вот мое решение:

я использовал

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 минуту, а если браузер не готов, он выходит из браузера и выходит из подпрограммы.

Источник

Я знаю, что это старый пост, но. У меня была та же проблема с моим кодом для загрузки изображений с веб-сайта с помощью автоматизации 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 мигает менее секунды, но он выполняет свою работу!

Источник
Другие вопросы по тегам