Мой скребок выдает ошибки вместо выхода из браузера, когда все сделано
Я написал скребок в vba для анализа информации о фильмах с торрент-сайта. я использовал IE а также queryselector выполнить задачу. Когда я выполняю свой код, он анализирует все вместе с сообщением об ошибке. Кажется, ошибка появляется из ниоткуда вместо продолжения. Если я отменю сообщение об ошибке, я смогу увидеть результаты. Я загрузил два изображения ниже, чтобы показать вам ошибки, которые у меня есть. Как я могу успешно выполнить код без каких-либо ошибок? Заранее спасибо.
Вот полный код:
Sub Torrent_Data()
Dim IE As New InternetExplorer, html As HTMLDocument
Dim post As Object
With IE
.Visible = False
.navigate "https://yts.am/browse-movies"
Do While .readyState <> READYSTATE_COMPLETE: Loop
Set html = .Document
End With
For Each post In html.querySelectorAll(".browse-movie-bottom")
Row = Row + 1: Cells(Row, 1) = post.queryselector(".browse-movie-title").innerText
Cells(Row, 2) = post.queryselector(".browse-movie-year").innerText
Next post
IE.Quit
End Sub
У меня ошибки:
Обе ошибки появляются одновременно. Я использую Internet Explorer 11.
С другой стороны, если я попытаюсь, как показано ниже, это принесет результаты успешно, без проблем.
Sub Torrent_Data()
Dim IE As New InternetExplorer, html As HTMLDocument
Dim post As Object
With IE
.Visible = False
.navigate "https://yts.am/browse-movies"
Do While .readyState <> READYSTATE_COMPLETE: Loop
Set html = .Document
End With
For Each post In html.getElementsByClassName("browse-movie-bottom")
Row = Row + 1: Cells(Row, 1) = post.queryselector(".browse-movie-title").innerText
Cells(Row, 2) = post.queryselector(".browse-movie-year").innerText
Next post
IE.Quit
End Sub
Ссылка, которую я добавил в библиотеку:
1. Microsoft Internet Controls
2. Microsoft HTML Object Library
Итак, что не так с queryselector или что мне здесь не хватает, чтобы успешно пройти? Есть ли какие-либо ссылки для добавления в библиотеку, чтобы избавиться от ошибок?
2 ответа
Итак, есть что-то серьезно недружелюбное в этой веб-странице. Это продолжало падать для меня. Поэтому я прибег к запуску 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://stackru.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
На сайте есть 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 фильма:
Кстати, аналогичный подход применяется в следующих ответах: 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14 и 15.