How can I display a URL as an image in an excel cell?
If you have a set of links in column J like:
and you run this short VBA macro:
Sub InstallPictures()
Dim i As Long, v As String
For i = 2 To 1903
v = Cells(i, "J").Value
If v = "" Then Exit Sub
With ActiveSheet.Pictures
.Insert (v)
End With
Next i
End Sub
each of the links will be opened and the associated Picture will be placed on the worksheet.
The pictures must the be properly sized and positioned.
EDIT#1:
Macros are very easy to install and use:
- ALT-F11 brings up the VBE window
- ALT-I ALT-M opens a fresh module
- paste the stuff in and close the VBE window
If you save the workbook, the macro will be saved with it. If you are using a version of Excel later then 2003, you must save the file as .xlsm rather than .xlsx
To remove the macro:
- bring up the VBE window as above
- clear the code out
- close the VBE window
To use the macro from Excel:
- ALT-F8
- Select the macro
- Touch RUN
To learn more about macros in general, see:
http://www.mvps.org/dmcritchie/excel/getstarted.htm
and
http://msdn.microsoft.com/en-us/library/ee814735(v=office.14).aspx
Macros must be enabled for this to work!
EDIT#2:
To avoid stopping on retrieval errors, use this version:
Sub InstallPictures()
Dim i As Long, v As String
On Error Resume Next
For i = 2 To 1903
v = Cells(i, "J").Value
If v = "" Then Exit Sub
With ActiveSheet.Pictures
.Insert (v)
End With
Next i
On Error GoTo 0
End Sub
This is my modification:
- Replace cell with link with picture (not a new column)
- Make pictures get saved with document (instead of links which can be fragile)
- Make images slightly smaller so that they have a chance of sorting with their cells.
Code Below:
Option Explicit
Dim rng As Range
Dim cell As Range
Dim Filename As String
Sub URLPictureInsert()
Dim theShape As Shape
Dim xRg As Range
Dim xCol As Long
On Error Resume Next
Application.ScreenUpdating = False
' Set to the range of cells you want to change to pictures
Set rng = ActiveSheet.Range("A2:A600")
For Each cell In rng
Filename = cell
' Use Shapes instead so that we can force it to save with the document
Set theShape = ActiveSheet.Shapes.AddPicture( _
Filename:=Filename, linktofile:=msoFalse, _
savewithdocument:=msoCTrue, _
Left:=cell.Left, Top:=cell.Top, Width:=60, Height:=60)
If theShape Is Nothing Then GoTo isnill
With theShape
.LockAspectRatio = msoTrue
' Shape position and sizes stuck to cell shape
.Top = cell.Top + 1
.Left = cell.Left + 1
.Height = cell.Height - 2
.Width = cell.Width - 2
' Move with the cell (and size, though that is likely buggy)
.Placement = xlMoveAndSize
End With
' Get rid of the
cell.ClearContents
isnill:
Set theShape = Nothing
Range("A2").Select
Next
Application.ScreenUpdating = True
Debug.Print "Done " & Now
End Sub
This one works much better in that the image end up beside the cell it belongs to.
Option Explicit
Dim rng As Range
Dim cell As Range
Dim Filename As String
Sub URLPictureInsert()
Dim theShape As Shape
Dim xRg As Range
Dim xCol As Long
On Error Resume Next
Application.ScreenUpdating = False
Set rng = ActiveSheet.Range("C1:C3000") ' <---- ADJUST THIS
For Each cell In rng
Filename = cell
If InStr(UCase(Filename), "JPG") > 0 Then '<--- ONLY USES JPG'S
ActiveSheet.Pictures.Insert(Filename).Select
Set theShape = Selection.ShapeRange.Item(1)
If theShape Is Nothing Then GoTo isnill
xCol = cell.Column + 1
Set xRg = Cells(cell.Row, xCol)
With theShape
.LockAspectRatio = msoFalse
.Width = 100
.Height = 100
.Top = xRg.Top + (xRg.Height - .Height) / 2
.Left = xRg.Left + (xRg.Width - .Width) / 2
End With
isnill:
Set theShape = Nothing
Range("A2").Select
End If
Next
Application.ScreenUpdating = True
Debug.Print "Done " & Now
End Sub