5
\$\begingroup\$

I've written a script in VBA which is able to parse image links from a website, download and store them in a local folder and finally set those images beside each link in an Excel file.

As the script is a bit big, I tried to make it clean so that it can serve the purpose errorlessly. However, it can do successfully what I mentioned above. There are always rooms for improvement, though.

Here is the full code:

Sub SavingImagesfinal()

Dim http As New XMLHTTP60, htmldoc As New HTMLDocument
Dim htmlas As Object, htmla As Object, html As Object, item As Object
Dim stream As Object, tempArr As Variant, fileSource As String
Dim pic As String, myPicture As Picture, rng As Range
Dim cl As Range, AspectRatio As Double


With http
    .Open "GET", "https://www.yify-torrent.org/search/1080p/", False
    .send
    htmldoc.body.innerHTML = .responseText
End With

Set htmlas = htmldoc.getElementsByClassName("movie")

    For Each htmla In htmlas
        Set html = htmla.getElementsByTagName("img")
        For Each item In html
            x = x + 1
            Cells(x, 1) = "https" & Split(item.src, "about")(1)
    
            fileSource = Replace(item.src, "about", "https")
            tempArr = Split(item.src, "/")
            tempArr = tempArr(UBound(tempArr))
        Next item
        
        With http
            .Open "GET", fileSource, False
            .send
        End With
    
        Set stream = CreateObject("ADODB.Stream")
        With stream
            .Open
            .Type = 1
            .write http.responseBody
            .SaveToFile ("D:\Test\Images\" & tempArr & ".jpg")
            .Close
        End With
    Next htmla

    Set rng = Range("B1:B18")

    For Each cl In rng
        pic = cl.Offset(0, -1)
        
        Set myPicture = ActiveSheet.Pictures.Insert(pic)
        
        AspectRatio = myPicture.Width / myPicture.Height
        With myPicture
            .ShapeRange.LockAspectRatio = msoFalse
            .Width = cl.Width
            .Height = cl.Height
            .Top = Rows(cl.Row).Top
            .Left = Columns(cl.Column).Left
        End With
    Next cl
End Sub
\$\endgroup\$

0

Browse other questions tagged or ask your own question.