如何解決“錯誤70權限被拒絕”？

Question

在2019年4月20日的代碼示例

對於某些聯賽，我正在努力從零碎體育中獲取一些機會。 但是由於我打開了太多鏈接，一段時間后我的代碼停止，並向我顯示以下錯誤：

運行時錯誤“ 70”：權限被拒絕。

我嘗試在代碼中放置一些延遲，但錯誤仍然存​​在。 有人可以幫我嗎？

Sub test()

Dim IE() As Object
Dim IE1 As Object
Dim doc As HTMLDocument
Dim link1x2 As String
Dim linkover As String
Dim linkbtts As String

''Novo código
Set IE1 = CreateObject("InternetExplorer.Application")
IE1.Visible = False
IE1.Navigate "https://www.oddsportal.com/matches/soccer/20190420"

Do While IE1.Busy Or IE1.ReadyState <> 4
    Application.Wait DateAdd("s", 1, Now)
Loop

Set doc = IE1.Document
Set jogos = doc.getElementsByClassName("deactivate")
ReDim IE(0 To jogos.Length * 3)
i = 2
j = 0

For Each jogo In jogos
    URL = jogo.Children(1).Children(0).href

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Set IE(j) = CreateObject("InternetExplorer.Application")
    link1x2 = URL & "#1X2;2"
    IE(j).Visible = False
    IE(j).Navigate link1x2

    Do While IE(j).Busy Or IE(j).ReadyState <> 4
        Application.Wait DateAdd("s", 1, Now)
    Loop

    Set doc = IE(j).Document
    Set equipas = doc.getElementById("col-content").Children(0)
    Set liga = doc.getElementsByClassName("home")(0).Children(0).Children(3)


    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    For k = 1 To 25
        If liga.innerText = Worksheets("Plan2").Range("A" & k) Then
            Worksheets("Plan1").Range("M" & i) = liga.innerText
            Worksheets("Plan1").Range("A" & i) = equipas.innerText
            oddH = doc.getElementsByClassName("aver")(0).Children(1).innerText
            oddD = doc.getElementsByClassName("aver")(0).Children(2).innerText
            oddA = doc.getElementsByClassName("aver")(0).Children(3).innerText

            Worksheets("Plan1").Range("C" & i) = oddH
            Worksheets("Plan1").Range("D" & i) = oddD
            Worksheets("Plan1").Range("E" & i) = oddA

            Set IE(j + 1) = CreateObject("InternetExplorer.Application")
            linkbtts = URL & "#bts;2"
            IE(j + 1).Visible = False
            IE(j + 1).Navigate linkbtts

            Do While IE(j + 1).Busy Or IE(j + 1).ReadyState <> 4
                Application.Wait DateAdd("s", 1, Now)
            Loop

            Set doc = IE(j + 1).Document

            oddBTTS = doc.getElementsByClassName("aver")(0).Children(1).innerText
            oddNBTTS = doc.getElementsByClassName("aver")(0).Children(2).innerText

            Worksheets("Plan1").Range("G" & i) = oddBTTS
            Worksheets("Plan1").Range("H" & i) = oddNBTTS
            IE(j + 1).Quit

            Set IE(j + 2) = CreateObject("InternetExplorer.Application")
            linkover = URL & "#over-under;2;2.50;0"
            IE(j + 2).Visible = False
            IE(j + 2).Navigate linkover

            Do While IE(j + 2).Busy Or IE(j + 2).ReadyState <> 4
                Application.Wait DateAdd("s", 1, Now)
            Loop

            Set doc = IE(j + 2).Document

            oddover = doc.getElementsByClassName("aver")(0).Children(2).innerText
            oddunder = doc.getElementsByClassName("aver")(0).Children(3).innerText

            Worksheets("Plan1").Range("J" & i) = oddover
            Worksheets("Plan1").Range("K" & i) = oddunder
            IE(j + 2).Quit
            i = i + 1
        End If
    Next k
    IE(j).Quit
    Application.Wait DateAdd("s", 1, Now)
    Application.Wait DateAdd("s", 1, Now)
    Application.Wait DateAdd("s", 1, Now)
    Application.Wait DateAdd("s", 1, Now)
    Application.Wait DateAdd("s", 1, Now)
    Application.Wait DateAdd("s", 1, Now)
    Application.Wait DateAdd("s", 1, Now)
    Application.Wait DateAdd("s", 1, Now)
    Application.Wait DateAdd("s", 1, Now)
    Application.Wait DateAdd("s", 1, Now)
    j = j + 1
Next jogo
End Sub

Answer 1

tl; dr;

最直接的問題之一是僅需要一個時就重復創建IE實例。 Permission denied的原因可能有多種，包括未正確處理/處置對象。

下面顯示了如何：

1. 使用單個IE實例更有效地工作
2. 使用助手功能收集所有要訪問的URL並過濾感興趣的國家
3. 正確獲取liga值並將國家/地區分配給國家/ country變量
4. 准確導航到頁面和選項卡之間。 簡單地連接一個后綴，例如#bts;2對我來說並不可靠，因為頁面幾乎總是默認為#1X2;2默認標簽。 部署以下點擊/事件使用以實現所需的導航
5. 應用基於條件的條件，等待內容通過演示的定時循環以及等待屬性值更改的循環出現
6. 減少的I / O，並通過在陣列中存儲結果，並寫入該數組，顯著提高執行時間results到片材，一次。 一次將一個項目寫入工作表是一項昂貴的I / O操作
7. 使用更快的CSS選擇器，現代瀏覽器已針對這些選擇器進行了優化

---

注意事項：

• 已對所有鏈接進行了測試，但仍有收緊代碼的余地
• 您可能需要對頁面上的每個事件（單擊/ FireEvent）進行基於條件的等待。 我已經展示了各種各樣的方法。

---

結果數組的示例內容（擴展了1個索引）：

特意留空索引以反映所需的輸出格式。 最后增加了一個country欄。

---

輸出示例：

---

要求：

1. VBE>工具>引用>向Microsoft HTML對象庫添加引用

---

VBA：

Option Explicit
'VBE > Tools > References:
' Microsoft Internet Controls
Public Sub GetOddsInfo()
    Dim ie As New InternetExplorer, url As String, matches()
    Dim i As Long, results(), ws As Worksheet, headers()
    Const MAX_WAIT_SEC As Long = 10
    url = "https://www.oddsportal.com/matches/soccer/20190423/"
    Set ws = ThisWorkbook.Worksheets("Plan1")
    headers = Array("Jogo", vbNullString, "Home Odds", "Draw odds", "Away Odds", vbNullString, "BTT", _
                    "NBTT", vbNullString, "O2", "U2", vbNullString, "Liga", "Country")

    With ie
        .Visible = True
        .Navigate2 url

        While .Busy Or .readyState < 4: DoEvents: Wend

        matches = GetMatches(url, .document)
        ReDim results(1 To UBound(matches, 1), 1 To 14)

        For i = LBound(matches, 1) To UBound(matches, 1)

            .Navigate2 matches(i, 4)             ' default is "#1X2;2"

            While .Busy Or .readyState < 4: DoEvents: Wend

            Dim equipas As String, liga As String, averages As Object, oddH As String, oddD As String, oddA As String
            Dim country As String
            country = matches(i, 1)
            liga = matches(i, 2)
            equipas = matches(i, 3)
            Set averages = .document.querySelectorAll(".aver td")
            oddH = "'" & averages.item(1).innerText 'to ensure odds are correctly formatted on output
            oddD = "'" & averages.item(2).innerText
            oddA = "'" & averages.item(3).innerText
            Set averages = Nothing

            If .document.querySelectorAll("[onclick*='uid\(13\)'], [onmousedown*='uid\(13\)']").Length > 1 Then
                On Error Resume Next
                .document.querySelector("[onclick*='uid\(13\)']").FireEvent "onclick" 'both teams to score
                .document.querySelector("[onmousedown*='uid\(13\)']").FireEvent "onmousedown"
                On Error GoTo 0

                While .Busy Or .readyState < 4: DoEvents: Wend

                Dim oddBtts  As String, oddNbtts As String, t As Date

                t = Timer
                Do
                    On Error Resume Next
                    Set averages = .document.querySelectorAll(".aver td")
                    On Error GoTo 0
                    If Timer - t > MAX_WAIT_SEC Then Exit Do
                Loop While averages.Length < 2

                If averages.Length > 1 Then
                    oddBtts = "'" & averages.item(1).innerText
                    oddNbtts = "'" & averages.item(2).innerText
                End If
            Else
                oddBtts = "No odds"
                oddNbtts = "No odds"
            End If
            Set averages = Nothing
            Dim oddOver As String, oddUnder As String

            If .document.querySelector("#bettype-tabs li:nth-of-type(5)").getAttribute("style") = "display: block;" Then

                .document.querySelector("#bettype-tabs li:nth-of-type(5) span").FireEvent "onmousedown" 'over/under

                Do
                Loop Until .document.querySelector(".table-chunk-header-dark").getAttribute("style") = "display: block;"

               If .document.querySelectorAll("[onclick*='P-2.50-0-0']").Length = 0 Then
                   oddOver = "No odds"
                   oddUnder = "No odds"
               Else

                .document.querySelector("[onclick*='P-2.50-0-0']").Click

                While .Busy Or .readyState < 4: DoEvents: Wend


                Set averages = .document.querySelectorAll(".aver td")
                oddOver = "'" & averages.item(2).innerText
                oddUnder = "'" & averages.item(3).innerText

                End If

            Else
                oddOver = "No odds"
                oddUnder = "No odds"
            End If

            Set averages = Nothing

            Dim resultsPositions(), resultsOrder(), j As Long
            resultsPositions = Array(1, 3, 4, 5, 7, 8, 10, 11, 13, 14) 'columns in output
            resultsOrder = Array(equipas, oddH, oddD, oddA, oddBtts, oddNbtts, oddOver, oddUnder, liga, country)

            For j = LBound(resultsPositions) To UBound(resultsPositions)
                results(i, resultsPositions(j)) = resultsOrder(j)
            Next
            'If i = 5 Then Stop                   ''for testing
        Next
        .Quit
    End With
    With ws
        .Cells(1, 1).Resize(1, UBound(headers) + 1) = headers
        .Cells(2, 1).Resize(UBound(results, 1), UBound(results, 2)) = results
    End With
End Sub

Public Function GetMatches(ByVal url As String, ByVal doc As Object) As Variant
    Dim results(), i As Long, listings As Object, html As HTMLDocument
    Dim countries(), liga As String, country As String, equipas As String, include As Boolean
    Set html = New HTMLDocument

    countries = Array("Argentina", "Austria", "Belgium", "Brazil", "China", "Denmark", "England", _
                      "Finland", "France", "Germany", "Greece", "Ireland", "Italy", "Japan", "Netherlands", "Norway", _
                      "Poland", "Portugal", "Russia", "Scotland", "Spain", "Sweden", "Switzerland", "Turkey", "USA")

    Set listings = doc.querySelectorAll("#table-matches tr")
    Dim games As Object, r As Long
    Set games = doc.querySelectorAll(".table-participant a")
    ReDim results(1 To games.Length, 1 To 4)     'country, liga, equipas, url

    For i = 0 To listings.Length - 1
        html.body.innerHTML = listings.item(i).innerHTML
        Select Case listings.item(i).className
        Case "dark center"
            country = Trim$(html.querySelector(".bfl").innerText)
            liga = html.querySelector(".bflp + a").innerText
            include = Not IsError(Application.Match(country, countries, 0))
        Case "odd deactivate"
            If include Then
                r = r + 1
                results(r, 1) = country
                results(r, 2) = liga
                results(r, 3) = html.querySelector("a").innerText
                results(r, 4) = Replace$(html.querySelector("a").href, "about:", "https://www.oddsportal.com")
            End If
        Case " deactivate"
            If include Then
                r = r + 1
                results(r, 1) = country
                results(r, 2) = liga
                results(r, 3) = html.querySelector("a").innerText
                results(r, 4) = Replace$(html.querySelector("a").href, "about:", "https://www.oddsportal.com")
            End If
        End Select
    Next
    results = Application.Transpose(results)
    ReDim Preserve results(1 To UBound(results, 1), 1 To r)
    results = Application.Transpose(results)
    GetMatches = results
End Function