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

Bring active cell back into view
Start at A1 and select to A9999 while writing a formula, you can't see A1 anymore. Press Ctrl+Backspace to bring active cell into view.

DataBlake

Well-known Member
Joined
Jan 26, 2015
Messages
781
Office Version
  1. 2016
Platform
  1. Windows
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
 

DataBlake

Well-known Member
Joined
Jan 26, 2015
Messages
781
Office Version
  1. 2016
Platform
  1. Windows
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
 

Dan_W

Active Member
Joined
Jul 11, 2018
Messages
438
Office Version
  1. 365
Platform
  1. Windows
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.
 

Watch MrExcel Video

Forum statistics

Threads
1,130,190
Messages
5,640,749
Members
417,165
Latest member
Hilders1

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
Top