无法在电子表格中的电影名称旁边嵌入电影海报

时间:2019-02-07 21:17:19

标签: excel vba image web-scraping

我已经用vba编写了一个脚本,可以从torrent网站下载不同的电影海报,并将它们嵌入到电子表格中与该电影有关的旁边。我的脚本可以解析电子表格中的电影名称,并将图像下载并保存在文件夹中。我无法做的是将下载的图像放在电子表格中每个电影名称的旁边。

如何在每个电影名称旁边的相关单元格中放置电影海报?

到目前为止,我的脚本是

Sub DownloadAndEmbedImages()
    'customized directory location within double quotes
    Const strPath$ = "C:\Users\WCS\Desktop\Test\"
    Dim Http As New XMLHTTP60, Html As New HTMLDocument
    Dim post As Object, imgArr As Variant, R&

    'check out if the folder is empty. If not empty, delete them to download anew
    If Dir(strPath & "*.*") <> "" Then Kill strPath & "*.*"

    With Http
        .Open "GET", "https://yts.am/browse-movies", False
        .send
        Html.body.innerHTML = .responseText
    End With

    For Each post In Html.getElementsByClassName("img-responsive")
        R = R + 1: Sheets("Sheet1").Cells(R, 1) = post.alt
        imgArr = Split(post.src, "/")
        imgArr = imgArr(UBound(imgArr) - 1) & ".jpg"

        Http.Open "GET", post.src, False
        Http.send

        With CreateObject("ADODB.Stream")
            .Open
            .Type = 1
            .write Http.responseBody
            .SaveToFile (strPath & imgArr)
            .Close
        End With
    Next post
End Sub

添加添加以执行上述脚本:

Microsoft XML, v6.0
Microsoft HTML Object library

0 个答案:

没有答案