Question

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

对于某些联赛，我正努力从“赔率运动”中脱颖而出。但是由于我打开了太多链接，一段时间后我的代码停止，并向我显示以下错误：

运行时错误'70'：权限被拒绝。

我尝试在代码中添加一些延迟，但是错误仍然存在。有人可以帮我吗？

[1, 2, 3]

Answer 1

tl; dr;

最明显的问题之一是仅需要一个时就重复创建IE实例。发生Permission denied的原因有很多，包括未正确处理/处置对象。

下面显示了如何：

使用单个IE实例更有效地工作
使用帮助器功能收集所有要访问的网址并过滤感兴趣的国家/地区
正确检索liga值并将国家/地区分配给country变量
准确浏览页面和标签之间。只需连接后缀即可#bts;2对我来说并不可靠，页面几乎总是默认为#1X2;2的默认标签。部署以下点击/事件使用以实现所需的导航
基于应用条件等待内容通过定时循环以及等待属性值更改的循环出现
通过将结果存储在数组中并将该数组results写一次到工作表中，减少I / O并显着提高执行时间。一次将一个项目写入工作表是一项昂贵的I / O操作
使用更快的CSS选择器，针对现代浏览器进行了优化

注意事项：

已通过所有链接进行了测试，但仍有收紧代码的空间
您可能需要基于条件来等待页面上的每个事件（单击/ FireEvent）。我已经展示了各种。

结果数组的示例内容（扩展了1个索引）：

故意留空索引以反映所需的输出格式。最后添加了country的另一列。

示例输出：

要求：

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

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

1 个答案: