9

Web サイトからサッカー選手のデータを取得して、個人的に使用されるデータベースに入力しようとしています。以下にコード全体を含めました。この最初のセクションは、2 番目の関数を呼び出してデータベースを埋めるルーパーです。昨年の夏、MSAccess でこのコードを実行してデータベースを埋めましたが、うまくいきました。

現在、プログラムが停止する前に、数チームしか満たすことができません。

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

このエラーに関して数え切れないほどの Web サイトを検索し、サブ関数を入れて数秒間待機するか、その他の回避策を実行して、このコードを変更しようとしました。それらのどれも問題を解決しません。また、これを複数のコンピューターで実行しようとしました。

最初のコンピューターは 3 つのチーム (または 2 番目の関数の 3 つの呼び出し) を通過しました。2 番目に遅いコンピューターが 5 チームを通過します。どちらも最終的にハングします。1 番目のコンピューターには Internet Explorer 10 があり、2 番目のコンピューターには 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

2 番目の関数:

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
4

3 に答える 3

3

同様の問題が発生したときに、この投稿が非常に役立つことがわかりました。これが私の解決策です：

使った

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 分間だけ実行され、ブラウザの準備ができていない場合は、ブラウザを終了してサブを終了します。

于 2014-03-01T11:25:40.080 に答える
1

これは古い投稿ですが。Excel VBA オートメーションを使用して Web サイトの画像をダウンロードするコードにも同じ問題がありました。一部のサイトでは、最初にブラウザでリンクを開かずに、リンクを使用して画像ファイルをダウンロードできません。ただし、次のコードで 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 は 1 秒未満しか点滅しませんが、仕事は完了です!

于 2018-11-09T03:10:30.923 に答える