如何解决“错误 70 权限被拒绝”？

Question

Example of what code do for day 20/04/2019

我正在尝试从一些联赛的奇数门户中获得一些赔率。但由于我打开了太多链接，一段时间后我的代码停止并显示以下错误：

运行时错误“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. 使用帮助函数收集所有要访问的网址并过滤感兴趣的国家/地区
3. 正确检索liga 值并将国家/地区分配给country 变量
4. 准确导航到页面和选项卡之间。简单地连接一个后缀，例如#bts;2 对我来说并不可靠，因为页面几乎总是默认为 #1X2;2 的默认选项卡。下面部署了点击/使用事件来实现所需的导航
5. 应用基于条件的等待内容出现，并显示定时循环以及等待属性值更改的循环
6. 通过将结果存储在一个数组中并将该数组results 写入工作表一次，从而减少 I/O 并显着提高执行时间。一次将一个项目写入工作表是一项昂贵的 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