Скребок выдает ошибки вместо выхода из браузера, когда все сделано

Ответ 1

Хорошо, поэтому на этой веб-странице есть что-то серьезно недружелюбное. Это продолжало рушиться для меня. Поэтому я прибегал к запуску javascript-программы в скриптовом движке/скриптовом управлении, и он работает.

Надеюсь, ты сможешь следовать за ним. Логика находится в javascript, добавленном в ScriptEngine. Я получаю два списка узлов, один список фильмов и один список лет; затем я перехожу через каждый массив в синхронизации и добавляю их в качестве пары ключевых значений в словарь сценариев Microsoft.

Option Explicit

'*Tools->References
'*    Microsoft Scripting Runtime
'*    Microsoft Scripting Control
'*    Microsoft Internet Controls
'*    Microsoft HTML Object Library

Sub Torrent_Data()
    Dim row As Long
    Dim IE As New InternetExplorer, html As HTMLDocument
    Dim post As Object

    With IE
        .Visible = True
        .navigate "https://yts.am/browse-movies"
        Do While .readyState <> READYSTATE_COMPLETE:
            DoEvents
        Loop
        Set html = .document
    End With

    Dim dicFilms As Scripting.Dictionary
    Set dicFilms = New Scripting.Dictionary

    Call GetScriptEngine.Run("getMovies", html, dicFilms)

    Dim vFilms As Variant
    vFilms = dicFilms.Keys

    Dim vYears As Variant
    vYears = dicFilms.Items

    Dim lRowLoop As Long
    For lRowLoop = 0 To dicFilms.Count - 1

        Cells(lRowLoop + 1, 1) = vFilms(lRowLoop)
        Cells(lRowLoop + 1, 2) = vYears(lRowLoop)

    Next lRowLoop

    Stop

    IE.Quit
End Sub

Private Function GetScriptEngine() As ScriptControl
    '* see code from this SO Q & A
    ' https://stackoverflow.com/questions/37711073/in-excel-vba-on-windows-how-to-get-stringified-json-respresentation-instead-of
    Static soScriptEngine As ScriptControl
    If soScriptEngine Is Nothing Then
        Set soScriptEngine = New ScriptControl
        soScriptEngine.Language = "JScript"

        soScriptEngine.AddCode "function getMovies(htmlDocument, microsoftDict) { " & _
                                    "var titles = htmlDocument.querySelectorAll('a.browse-movie-title'), i;" & _
                                    "var years = htmlDocument.querySelectorAll('div.browse-movie-year'), j;" & _
                                    "if ( years.length === years.length) {" & _
                                    "for (i=0; i< years.length; ++i) {" & _
                                    "   var film = titles[i].innerText;" & _
                                    "   var year = years[i].innerText;" & _
                                    "   microsoftDict.Add(film, year);" & _
                                    "}}}"

    End If
    Set GetScriptEngine = soScriptEngine
End Function

Ответ 2

На веб-сайте есть API. Проверьте, например, результат из URL https://yts.am/api/v2/list_movies.json?page=1&limit=50, который фактически представляет 50 фильмов с первой страницы последней категории фильмов в формате JSON.

Взгляните на приведенный ниже пример. Импортируйте модуль JSON.bas в проект VBA для обработки JSON.

Option Explicit

Sub Test()

    Dim sJSONString As String
    Dim vJSON
    Dim sState As String
    Dim lPage As Long
    Dim aRes()
    Dim i As Long
    Dim aData()
    Dim aHeader()

    With Sheets(1)
        .Cells.Delete
        .Cells.WrapText = False
    End With
    lPage = 1
    aRes = Array()
    Do
        With CreateObject("MSXML2.XMLHTTP")
            .Open "GET", "https://yts.am/api/v2/list_movies.json?page=" & lPage & "&limit=50", False
            .send
            sJSONString = .responseText
        End With
        JSON.Parse sJSONString, vJSON, sState
        If Not vJSON("data").Exists("movies") Then Exit Do
        vJSON = vJSON("data")("movies")
        ReDim Preserve aRes(UBound(aRes) + UBound(vJSON) + 1)
        For i = 0 To UBound(vJSON)
            Set aRes(UBound(aRes) - UBound(vJSON) + i) = vJSON(i)
        Next
        lPage = lPage + 1
        Debug.Print "Parsed " & (UBound(aRes) + 1)
        DoEvents
    Loop
    JSON.ToArray aRes, aData, aHeader
    With Sheets(1)
        OutputArray .Cells(1, 1), aHeader
        Output2DArray .Cells(2, 1), aData
        .Columns.AutoFit
    End With
    MsgBox "Completed"

End Sub

Sub OutputArray(oDstRng As Range, aCells As Variant)

    With oDstRng
        .Parent.Select
        With .Resize(1, UBound(aCells) - LBound(aCells) + 1)
            .NumberFormat = "@"
            .Value = aCells
        End With
    End With

End Sub

Sub Output2DArray(oDstRng As Range, aCells As Variant)

    With oDstRng
        .Parent.Select
        With .Resize( _
                UBound(aCells, 1) - LBound(aCells, 1) + 1, _
                UBound(aCells, 2) - LBound(aCells, 2) + 1)
            .NumberFormat = "@"
            .Value = aCells
        End With
    End With

End Sub

Выход для меня следующим образом, на данный момент есть 7182 фильмов всего:

BTW, аналогичный подход применяется в следующих ответах: 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14 и 15.

Ответ 3

Ну, похоже, я нашел решение для работы с .queryselectorAll(). После много экспериментов я заметил, что у него есть только некоторые проблемы с for loop, поэтому я тактично избегал for loop и вместо этого использовал with block для выполнения той же работы. Вот как мы можем достичь этого:

Sub Torrent_Data()

    With CreateObject("InternetExplorer.Application")
        .Visible = False
        .navigate "https://yts.am/browse-movies"
        While .Busy = True Or .readyState < 4: DoEvents: Wend

        With .document.querySelectorAll(".browse-movie-bottom")
            For I = 0 To .Length - 1
                Cells(I + 1, 1) = .Item(I).querySelector(".browse-movie-title").innerText
                Cells(I + 1, 2) = .Item(I).querySelector(".browse-movie-year").innerText
            Next I
        End With
    End With

End Sub

Btw, вышеуказанный script может быть выполнен без ссылки на что-либо в библиотеке.