Как решить "ошибка 70, разрешение отклонено"?

Question

Как решить "ошибка 70, разрешение отклонено"?

Пример того, что код делает на день 20/04/2019

Я пытаюсь сгрести некоторые шансы с oddsportal на некоторые лиги. Но так как я открываю слишком много ссылок, через некоторое время мой код останавливается и показывает следующую ошибку:

Ошибка во время выполнения "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

2

vba web-scraping

Источник

user11420328 01 май '19 в 11:06

1 ответ

Решение

Другие вопросы по тегам vba web-scraping

user6241235 01 май '19 в 11:56 2019-05-01 11:56 · Accepted Answer · 2019-05-01 11:56

ТЛ; др;

Одной из сразу очевидных проблем является повторное создание экземпляров IE, когда нужен только один. Permission denied Это может произойти по ряду причин, включая неправильное обращение с предметами или их утилизацию.

Ниже показано, как:

Работать эффективнее с одним экземпляром IE
Используйте вспомогательную функцию для сбора всех URL-адресов для посещения и фильтрации по интересующим странам
Правильно получить liga оценить и назначить страну country переменная
Точно перейдите на страницы и между вкладками. Просто конкатенация суффикса, например #bts;2 не оказался надежным для меня со страницей почти всегда по умолчанию на вкладке по умолчанию #1X2;2, Ниже клики / использование событий развернуты для достижения необходимой навигации
Применить на основе условий ожидает присутствия контента с демонстрацией временного цикла, а также цикла, ожидающего изменения значения атрибута
Уменьшите ввод-вывод и значительно увеличьте время выполнения, сохраняя результаты в массиве и записывая этот массив, results Один раз на лист. Записать элемент за раз на листе - дорогостоящая операция ввода-вывода
Используйте более быстрые CSS-селекторы, для которых оптимизированы современные браузеры

Предостережения:

Протестировано со всеми ссылками, но есть возможность ужесточить код
Вероятно, вам может потребоваться ожидание на основе условий для каждого события (нажатие /FireEvent) на странице. Я продемонстрировал множество из них.

Пример содержимого массива результатов (расширен 1 индекс):

Пустые индексы намеренно оставляются для отражения желаемого формата вывода. Один дополнительный столбец для country добавляется в конце.

Пример вывода:

Требования:

VBE> Инструменты> Ссылки> Добавить ссылку на Microsoft HTML Object Library

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