vba - 无法使我的脚本异步工作

Question

我已经在 vba 中编写了一个脚本来从一个torrent网站上抓取不同movie names的内容。尽管and出现在它的登录页面中，但我创建了脚本来解析相同的深入一层（从他们的主页）。更清楚地说，这是我所说的主页之一。我的脚本完美地解析了它们。但是，我的意图是做同样的异步请求。目前脚本正在同步完成它的工作（以阻塞方式）。genrenamegenre

在我之前的帖子中，我从omegastripes谁创建了一个which more or less performs like how multiprocessing works打算工作的脚本 ()那里得到了答案asynchronously。所以这就是我找到这个想法但无法在以下脚本中实现的地方。

到目前为止我的尝试：

Sub GetInfo()
    Const URL = "https://yts.am/browse-movies"
    Dim Http As New ServerXMLHTTP60, Html As New HTMLDocument
    Dim post As HTMLDivElement, oName$, oGenre$, R&
    Dim I&, key As Variant, iDic As Object
    Set iDic = CreateObject("Scripting.Dictionary")

    With Http
        .Open "GET", URL, False
        .send
        Html.body.innerHTML = .responseText
    End With

    With Html.querySelectorAll(".browse-movie-wrap .browse-movie-title")
        For I = 0 To .Length - 1
            iDic(.Item(I).getAttribute("href")) = 1
        Next I
    End With

    For Each key In iDic.keys
        With Http
            .Open "GET", key, False
            .send
            Html.body.innerHTML = .responseText
        End With

        oName = Html.querySelector("h1").innerText
        oGenre = Html.querySelector("h2").NextSibling.innerText
        R = R + 1: Cells(R, 1) = oName
        Cells(R, 2) = oGenre
    Next key
End Sub

我怎样才能在上面的脚本中进行任何更改以使其正常工作asynchronously？

标签： vbaasynchronousweb-scraping

Answer 1

这是显示带有异步请求池的单循环解析器实现的示例。该代码解析从第一个到最后一个的所有浏览页面和电影页面，这两种类型是同时解析的。从浏览页面解析电影 URL 并将其放置在电影队列中，然后解析队列中每个电影页面的详细信息并输出到工作表。它处理所有 HTTP 请求错误类型并重试直到限制。

将以下代码放入标准模块：

Option Explicit

Sub Test()

    Const PoolCapacity = 30 ' Async requests qty
    Const MoviesMin = 55 ' Movies in queue + expected movies min qty to request new browse page
    Const ReqDelayMin = 0.15 ' Min delay between requests to avoid ban, sec
    Const ReqTimeout = 15 ' Request timeout, sec
    Const ReqRetryMax = 3 ' Attempts for each request before quit

    Dim oWS As Worksheet
    Dim y As Long
    Dim ocPool As Collection
    Dim ocMovies As Collection
    Dim lMoviesPerPage As Long
    Dim lBPageIndex As Long
    Dim lBPagesInPoolQty As Long
    Dim bLastBPageReached As Boolean
    Dim dPrevReqSent As Double
    Dim i As Long
    Dim bBPageInPool As Boolean
    Dim dT As Double
    Dim bFail As Boolean
    Dim sResp As String
    Dim oMatches As Object
    Dim oMatch
    Dim oReq As Object
    Dim oRequest As cRequest

    ' Prepare worksheet
    Set oWS = ThisWorkbook.Sheets(1)
    oWS.Cells.Delete
    y = 1
    ' Init
    Set ocPool = New Collection ' Requests async pool
    Set ocMovies = New Collection ' Movies urls queue
    lMoviesPerPage = 20 ' Movies per page qty
    lBPageIndex = 1 ' Current browse page index for request
    bLastBPageReached = False ' Last page reached flag
    dPrevReqSent = -60# * 60# * 24# ' Init delay timer
    ' Start parsing
    Do
        lBPagesInPoolQty = 0 ' How many browse pages currently in pool
        ' Check pool for all flagged and completed requests
        For i = ocPool.Count To 1 Step -1
            bBPageInPool = Not ocPool(i).IsMovie
            ' Delay from last request
            dT = Timer - dPrevReqSent
            If dT < 0 Then dT = dT + 60# * 60# * 24#
            Select Case True
                ' Check request has no sent flag
                Case Not ocPool(i).NeedSend
                    On Error Resume Next
                    bFail = False
                    sResp = ""
                    With ocPool(i).HTTPRequest
                        ' Check http request is ready and status is OK
                        Select Case True
                            Case .ReadyState < 4 ' Not ready
                            Case .Status \ 100 <> 2 ' Wrong status
                                Debug.Print .Status & " / " & .StatusText & " (" & ocPool(i).URL & ")"
                                bFail = True
                            Case Else ' Ready and OK
                                sResp = .ResponseText
                        End Select
                    End With
                    If sResp = "" Then
                        ' Request elapsed time
                        dT = Timer - ocPool(i).SendTimer
                        If dT < 0 Then dT = dT + 60# * 60# * 24#
                        ' Check request is failed
                        Select Case True
                            Case Err.Number <> 0 ' Runtime error
                                Debug.Print Err.Number & " / " & Err.Description & " (" & ocPool(i).URL & ")"
                                bFail = True
                            Case dT > ReqTimeout ' Timeout
                                Debug.Print "Timeout (" & ocPool(i).URL & ")"
                                bFail = True
                        End Select
                        On Error GoTo 0
                        If bFail Then ' Request has been failed
                            ocPool(i).FailsCount = ocPool(i).FailsCount + 1
                            ' Check attempts
                            If ocPool(i).FailsCount > ReqRetryMax Then
                                Debug.Print "Quit (" & ocPool(i).URL & ")"
                                ocPool.Remove i ' Quit
                                bBPageInPool = False
                            Else
                                ocPool(i).NeedSend = True ' Raise send flag to retry
                            End If
                        End If
                    Else ' Response received
                        If ocPool(i).IsMovie Then
                            ' Response from movie page
                            With CreateObject("VBScript.RegExp")
                                ' Parse Title, Year, Genre
                                ' <h1 itemprop\="name">___</h1>\s*<h2>___</h2>\s*<h2>___</h2>
                                .Pattern = "<h1 itemprop\=""name"">([^<]*)</h1>\s*<h2>([^<]*)</h2>\s*<h2>([^<]*)</h2>"
                                Set oMatches = .Execute(sResp)
                                If oMatches.Count = 1 Then ' Output to worksheet
                                    oWS.Cells(y, 1).Value = oMatches(0).SubMatches(0)
                                    oWS.Cells(y, 2).Value = oMatches(0).SubMatches(1)
                                    oWS.Cells(y, 3).Value = oMatches(0).SubMatches(2)
                                    y = y + 1
                                End If
                            End With
                        Else
                            ' Response from browse page
                            With CreateObject("VBScript.RegExp")
                                .Global = True
                                ' Parse movies urls
                                ' <a href="___" class="browse-movie-link">
                                .Pattern = "<a href=""([^""]*)"" class=""browse-movie-link"">"
                                Set oMatches = .Execute(sResp)
                                For Each oMatch In oMatches
                                    ocMovies.Add oMatch.SubMatches(0) ' Movies queue fed
                                Next
                                ' Parse next page button
                                ' <a href="/browse-movies?page=___">Next
                                .Pattern = "<a href\=""/browse-movies\?page\=\d+"">Next "
                                bLastBPageReached = bLastBPageReached Or Not .Test(sResp)
                            End With
                            If Not bLastBPageReached Then lMoviesPerPage = oMatches.Count ' Update lMoviesPerPage
                        End If
                        ocPool.Remove i
                        bBPageInPool = False
                    End If
                ' Check request has send flag raised and delay enough
                Case dT > ReqDelayMin
                    ' Send the request
                    Set oReq = CreateObject("MSXML2.ServerXMLHTTP.6.0")
                    With oReq
                        .Open "GET", ocPool(i).URL, True
                        ' .SetProxy 2, "190.12.55.210:46078"
                        .SetRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 6.1; Win64; x64)"
                        .Send
                    End With
                    ocPool(i).NeedSend = False
                    ocPool(i).SendTimer = Timer
                    dPrevReqSent = ocPool(i).SendTimer
                    Set ocPool(i).HTTPRequest = oReq
            End Select
            If bBPageInPool Then lBPagesInPoolQty = lBPagesInPoolQty + 1
            DoEvents
        Next
        ' Check if there is a room for a new request in pool
        If ocPool.Count < PoolCapacity Then
            ' Add one new request to pool
            ' Check if movies in queue + expected movies are not enough
            If ocMovies.Count + lBPagesInPoolQty * lMoviesPerPage < MoviesMin And Not bLastBPageReached Then
                ' Add new request for next browse page to feed movie queue
                Set oRequest = New cRequest
                With oRequest
                    .URL = "https://yts.am/browse-movies?page=" & lBPageIndex
                    .IsMovie = False
                    .NeedSend = True
                    .FailsCount = 0
                End With
                ocPool.Add oRequest
                lBPageIndex = lBPageIndex + 1
            Else
                ' Check if movie page urls are parsed and available in queue
                If ocMovies.Count > 0 Then
                    ' Add new request for next movie page from queue
                    Set oRequest = New cRequest
                    With oRequest
                        .URL = ocMovies(1)
                        .IsMovie = True
                        .NeedSend = True
                        .FailsCount = 0
                    End With
                    ocPool.Add oRequest
                    ocMovies.Remove 1
                End If
            End If
        End If
        DoEvents
    Loop While ocPool.Count > 0 ' Loop until the last request completed
    MsgBox "Completed"

End Sub

将以下代码放入名为的类模块中cRequest：

Public URL As String
Public IsMovie As Boolean
Public NeedSend As Boolean
Public SendTimer As Double
Public HTTPRequest As Object
Public FailsCount As Long

Const ReqDelayMin小心减少请求之间的延迟。一旦以高速率启动它，它会工作一段时间并导致触发 Cloudflare DDoS 保护，目前，我无法直接从我的 IP 使代码工作，唯一的方法是对请求使用代理（您可以看到带有.SetProxy) 的注释行。即使在 Chrome 中，我现在也得到 Cloudflare 重定向：

因此，该方法只是揭示了问题，但是，最安全和更有效的方法是使用本答案中描述的网站 API。