Using URLs to Insert Pictures [VBA]

DataBlake

Well-known Member
Joined
Jan 26, 2015
Messages
781
Office Version
  1. 2016
Platform
  1. Windows
Hello all,

So KuTools has this code which i've adapted for my needs, and when i run through the code with F8 I'm unsure of where it messes up.
I have 3 columns of image url's (some cells are blank) I set the range to the first column with images which is column B
I want it to insert the images to the column to the right of the range (column C)

Code:
Sub URLPictureInsert()
'Updateby Extendoffice 20161116
    Dim Pshp As Shape
    Dim xRg As Range
    Dim xCol As Long
    Dim lastrow As Long
    
    lastrow = Range("A" & Rows.Count).End(xlUp).Row
    
    On Error Resume Next
    Application.ScreenUpdating = False
    Set Rng = ActiveSheet.Range("B:B" & lastrow)
    For Each cell In Rng
        filenam = cell
        ActiveSheet.Pictures.Insert(filenam).Select
        Set Pshp = Selection.ShapeRange.Item(1)
        If Pshp Is Nothing Then GoTo lab
        xCol = cell.Column + 1
        Set xRg = Cells(cell.Row, xCol)
        With Pshp
            .LockAspectRatio = msoFalse
            .Width = 100
           .Height = 100
            .Top = xRg.Top + (xRg.Height - .Height) / 2
            .Left = xRg.Left + (xRg.Width - .Width) / 2
        End With
lab:
    Set Pshp = Nothing
    Range("B2").Select
    Next
    Application.ScreenUpdating = True
End Sub

can anyone point out where this isn't working as intended?
It runs but does nothing/inserts nothing
 

Excel Facts

Difference between two dates
Secret function! Use =DATEDIF(A2,B2,"Y")&" years"&=DATEDIF(A2,B2,"YM")&" months"&=DATEDIF(A2,B2,"MD")&" days"
okay so after poking around i've changed the code to
Code:
Sub URLPictureInsert()
'Updateby Extendoffice 20161116
    Dim Pshp As Shape
    Dim i As Long
    Dim lastRow As Long
    Dim urlRng As Range
    Dim trgtRng As Range
    
    
    lastRow = Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To lastRow

   Set urlRng = Range("B" & i)
   Set trgtRng = Range("C" & i)
    
        filenam = urlRng
        ActiveSheet.Pictures.Insert(filenam).Select
        Set Pshp = Selection.ShapeRange.Item(1)
        If Pshp Is Nothing Then trgtRng = ""
        
    With Pshp
            .LockAspectRatio = msoFalse
            .Width = 15
            .Height = 15
            .Top = trgtRng.Top
            .Left = trgtRng.Left
    End With

        
    Next i
End Sub

this works perfectly until it runs into a blank cell
 
Upvote 0
here is my final version where it skips blank cells in the url column
If you need to put an image based on a url into your worksheet just change urlRng column for the URL column and the trgtRng column for where you want the image to appear in.
As well changing the width/height to suit your needs

Code:
Sub URLPictureInsert()
    Dim Pshp As Shape
    Dim i As Long
    Dim lastRow As Long
    Dim urlRng As Range
    Dim trgtRng As Range
    
    
    lastRow = Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To lastRow

   Set urlRng = Range("B" & i)
   Set trgtRng = Range("C" & i)
   
If urlRng = "" Then GoTo lastline
    
        filenam = urlRng
        ActiveSheet.Pictures.Insert(filenam).Select
        Set Pshp = Selection.ShapeRange.Item(1)
        If Pshp Is Nothing Then trgtRng = ""
        
    With Pshp
            .LockAspectRatio = msoFalse
            .Width = 15
            .Height = 15
            .Top = trgtRng.Top
            .Left = trgtRng.Left
    End With

lastline:
    Next i
End Sub
 
Upvote 0
As an alternative:
VBA Code:
Sub InsertWebPicture(URL As String, target As Range, Optional picWidth As Long = -1, Optional picHeight As Long = -1)
    target.Parent.Shapes.AddPicture URL, True, True, target.Left, target.Top, picWidth, picHeight
End Sub
This approach uses the pictures default width and height, unless you intentionally change it.
 
Upvote 0

Forum statistics

Threads
1,213,513
Messages
6,114,064
Members
448,545
Latest member
kj9

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top