• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Unable to place the downloaded images right next to each url in a spreadsheet

shahin

Active Member
I've written a script in vba to download few images using some urls already available in coulmn B in a spreadsheet and place the downloaded images right next to concerning urls in column C. If it were not for amazon I could have done the same using the following piece of code:

Code:
Sub InsertImages()
    Dim pics$, myPics As Shape, PicExists As Boolean, cel As Range

    For Each cel In Range("C2", Range("B2").End(xlDown).Offset(0, 1))
        PicExists = False
        pics = cel.Offset(0, -1)

        For Each myPics In ActiveSheet.Shapes
            If myPics.TopLeftCell.Row = cel.Row Then PicExists = True: Exit For
        Next myPics

        If Not PicExists Then
            With ActiveSheet.Pictures.Insert(pics)
               .ShapeRange.LockAspectRatio = msoTrue
               .Top = Rows(cel.Row).Top
               .Left = Columns(cel.Column).Left
            End With
        End If
    Next cel
End Sub

But the thing is I can't do that because amazon does not let me accomplish the task the way I tried above.

However, I tried another way (fully hypothetical) to do the trick. Firstly I downloaded the images using ADODB and then comply with the above method to place the images right next to concerning cells using the following approach but failed miserably. How can i make it a go successfully?

Code:
Sub DownloadFileFirst()
    Dim Http As New XMLHTTP60, cel As Range
    Dim temparr As Variant, StrFile$

    For Each cel In Range("B2:B" & Cells(Rows.Count, "B").End(xlUp).Row)
        temparr = Split(cel, "/")
        temparr = temparr(UBound(temparr))

        Http.Open "GET", cel, False
        Http.send

        With CreateObject("ADODB.Stream")
             .Open
             .Type = 1
             .write Http.responseBody
             .SaveToFile "C:\Users\WCS\Desktop\UpDown\" & temparr, 2
             .Close
         End With
    Next cel
   
    For Each cel In Range("B2:B" & Cells(Rows.Count, "B").End(xlUp).Row)
        StrFile = Dir("C:\Users\WCS\Desktop\UpDown\")
        Do While Len(StrFile) > 0
            If InStr(cel, StrFile) > 0 Then
                With cel(1, 2).Pictures.Insert(StrFile)
                   .ShapeRange.LockAspectRatio = msoTrue
                   .Top = Rows(.Row).Top
                   .Left = Columns(.Column).Left
                End With
                StrFile = Dir
            End If
        Loop
    Next cel
End Sub

Images urls are in column B and I wish to place the downloaded images right next to each url in column C.

Few urls are like:

Code:
https://images-na.ssl-images-amazon.com/images/I/51c4wH-24hL._SL100_SS100_.jpg
https://images-na.ssl-images-amazon.com/images/I/414OmQfjqBL._SL100_SS100_.jpg
https://images-na.ssl-images-amazon.com/images/I/21SvLWEwzuL._SL100_SS100_.jpg
https://images-na.ssl-images-amazon.com/images/I/51G7w%2BTdPAL._SL100_SS100_.jpg
https://images-na.ssl-images-amazon.com/images/I/516QJcni8fL._SL100_SS100_.jpg
 
Untested, maybe use cell(1,2)?

Code:
.Top = cel(1,2).Top
.Left = cel(1,2).Left

I would probably use the API method to download a file though I prefer the first method when possible.
 
Why are you using DIR() to retrieve file and looping each file to find match? When you already have the file name & folder path already within the code.

I'd also use .Shapes.Addpicture() method.

Code:
Sub DownloadFileFirst()
    Dim Http As New XMLHTTP60, cel As Range
    Dim temparr As Variant, StrFile$
    Dim fpath$, p As Shape
    fpath = "C:\Test\UpDown\"
    For Each cel In Range("B2:B" & Cells(Rows.Count, "B").End(xlUp).Row)
        temparr = Split(cel, "/")
        temparr = temparr(UBound(temparr))

        Http.Open "GET", cel, False
        Http.send

        With CreateObject("ADODB.Stream")
            .Open
            .Type = 1
            .write Http.responseBody
            .SaveToFile fpath & temparr, 2
            .Close
        End With
    Next cel
   
    For Each cel In Range("B2:B" & Cells(Rows.Count, "B").End(xlUp).Row)
        temparr = Split(cel, "/")
        temparr = temparr(UBound(temparr))
        With ActiveSheet
            Set p = .Shapes.AddPicture(fpath & temparr, False, True, cel.Offset(, 1).Left, cel.Top, -1, -1)
            cel.RowHeight = p.Height
        End With
    Next
End Sub
 
@Sir Chiro, Its a long time since i hear anything from you. I realy can't understand as to how i can make it a go successfully.It would be a great pleasure if i could get any specific instruction from you to make the code executable.
 
Did my code not work?

At any rate, major issue is here.
Code:
With cel(1, 2).Pictures.Insert(StrFile)
StrFile will return only the file name, so you'd need to concatenate it with folder path.

But, my question is... Why loop through all the file names?
When you can extract file name from cel.Value and concatenate it with static folder path.
 
@Sir Chihiro, your code never fails to meet the criteria. I was not around so I had no option to test that. I'll surely let you know. Thanks.
 
One last thing to know on this sir: is it possible to do the same without creating any folder, I meant saving the images in the clipboard and reuse it?
 
Probably. If you have code for copying, then code to paste would be something like...
Code:
ActiveSheet.PasteSpecial Format:="Bitmap", link:=False, DisplayAsIcon:=False

Then you can manipulate it like any other shape.
 
Back
Top