I have used the below VBA code to insert pictures from an image URL.
For some reason, this code works with some image URLs but not for others.
For example, the below URLs will work
http://a.espncdn.com/combiner/i?img=/i/headshots/nfl/players/full/3123076.png&w=350&h=254
https://upload.wikimedia.org/wikipedia/commons/thumb/c/c8/David_Njoku_2018.jpg/220px-David_Njoku_2018.jpg
But the below will not
http://ecx.images-amazon.com/images/I/41HkOMYqc9L.SL500.jpg
http://ecx.images-amazon.com/images/I/41gWzC%2B5IqL.SL500.jpg
http://ecx.images-amazon.com/images/I/41gWzC%2B5IqL.SL500.jpg
Does anyone know if there are any limitations to the "ActiveSheet.Pictures.Insert" command?
Below is the code i am using
Sub URLPictureInsert()
Dim Pshp As Shape
Dim xRg As Range
Dim xCol As Long
On Error Resume Next
Application.ScreenUpdating = False
Set Rng = ActiveSheet.Range("A1 :A24")
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("A1").Select
Next
Application.ScreenUpdating = True
End Sub
Related
I'm trying to create the following template:
The user creates a table in a "Data Entry" worksheet that lists the following:
File path ie: P:\Phone Camera Dump\20121224_111617.jpg
Range where the picture is to be placed in the "PICS" worksheet.
Once the list is finalized, the user executes and images are placed within the ranges specified on the "PICS" worksheet and dynamically re-sized.
Presently the range has a set width of 624px and a height of 374px, but ideally, I would like the image to resize (aspect ratio not locked) dynamically in the width and height change.
I've used the following code as a base but am struggling with how to incorporate the cell ranges instead of the static row updates:
Sub InsertSeveralImages()
Dim pic_Path As String 'File path of the picture
Dim cl As Range, Rng As Range
Dim WS_Templte As Worksheet
Set WS_Templte = Worksheets("PICS")
Set Rng = Worksheets("Data Entry").Range("C13:C42")
pastingRow = 2
For Each cl In Rng
pic_Path = cl.Value
Set InsertingPicture = WS_Templte.Pictures.Insert(pic_Path)
'Setting of the picture
With InsertingPicture
.ShapeRange.LockAspectRatio = msoTrue
.Height = 100
.Top = WS_Templte.Rows(pastingRow).Top
.Left = WS_Templte.Columns(3).Left
End With
pastingRow = pastingRow + 5
Next cl
Set myPicture = Nothing
WS_Templte.Activate
End Sub
Any thoughts?
I figured it out. Here is the code in case anyone wants to use it:
Public Sub InsertPictures()
Dim vntFilePath As Variant
Dim rngFilePath As Range
Dim vntPastePath As Variant
Dim rngPastePath As Range
Dim lngCounter As Long
Dim pic As Picture
Set WS_Templte = Worksheets("PICS")
On Error GoTo ErrHandler
With ThisWorkbook.Sheets("PICS") '<-- Change sheet name accordingly
' Set first cell containing a row number
Set rngFilePath = .Range("BJ7")
vntFilePath = rngFilePath.Value
' Set first cell containing a paste range
Set rngPastePath = .Range("BK7")
vntPastePath = rngPastePath.Value
Do Until IsEmpty(vntFilePath)
If Dir(vntFilePath) = "" Then vntFilePath = strNOT_FOUND_PATH
Set pic = .Pictures.Insert(vntFilePath)
lngCounter = lngCounter + 1
With pic
.ShapeRange.LockAspectRatio = msoFalse
If .ShapeRange.Rotation = 90! Or .ShapeRange.Rotation = 270! Then
.Height = Application.CentimetersToPoints(16.3)
.Width = Application.CentimetersToPoints(10.03)
.Top = WS_Templte.Rows(rngPastePath).Top - (.Height - .Width) / 2#
.Left = WS_Templte.Columns(4).Left + (.Height - .Width) / 2#
Else
.Width = Application.CentimetersToPoints(10.03)
.Height = Application.CentimetersToPoints(16.3)
.Top = WS_Templte.Rows(rngPastePath).Top
.Left = WS_Templte.Columns(4).Left
End If
End With
Set rngFilePath = rngFilePath.Offset(1)
vntFilePath = rngFilePath.Value
Set rngPastePath = rngPastePath.Offset(1)
vntPastePath = rngPastePath.Value
Loop
End With
MsgBox lngCounter & " pictures were inserted.", vbInformation
ExitProc:
Set rngFilePath = Nothing
Set pic = Nothing
Exit Sub
ErrHandler:
MsgBox Err.Description, vbExclamation
Resume ExitProc
End Sub
I am trying to create a macro that inserts an image into one cell when the user enters specific information into an other cell. Right now it's working but not right away. The user has to change the cell then click off of it and then back on. Here is my macro:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range
Set KeyCells = Range("b7:f7,b13:f13,b19:f19,b25:f25,b31:f31,b37:f37")
Dim myPict As Picture
Dim ws As Worksheet
ActiveCell.NumberFormat = "#"
Dim curcell As Range
Set curcell = ActiveWindow.ActiveCell.Offset(-3, 0)
Dim PictureLoc As String
PictureLoc = "C:\Users\WPeter\Desktop\VBA_TEST\test\" & ActiveCell.Text & ".jpeg"
If Not Intersect(KeyCells, Range(Target.Address)) Is Nothing Then
For Each sh In ActiveSheet.Shapes
If sh.TopLeftCell.Address = curcell.Address Then sh.Delete
Next
With ActiveCell.Offset(-3, 0)
On Error GoTo errormessage:
Set myPict = ActiveSheet.Pictures.insert(PictureLoc)
myPict.Height = 119
myPict.Width = 119
myPict.Top = .Top + .Height / 2 - myPict.Height / 2
myPict.Left = .Left + .Width / 2 - myPict.Width / 2
myPict.Placement = xlMoveAndSize
errormessage:
If Err.Number = 1004 Then
MsgBox "File does not Exist, Please first update photo with .jpg File"
End If
End With
End If
End Sub
Any help would be appreciated. Thanks so much!
Untested but this should give you a rough idea of how it could work:
Private Sub Worksheet_Change(ByVal Target As Range)
Const FLDR = "C:\Users\WPeter\Desktop\VBA_TEST\test\"
Dim KeyCells As Range, myPict As Picture, cPic As Range
Dim c As Range, rng As Range, PictureLoc As String
Set KeyCells = Range("b7:f7,b13:f13,b19:f19,b25:f25,b31:f31,b37:f37")
Set rng = Application.Intersect(Target, KeyCells)
If rng Is Nothing Then Exit Sub
RemovePics rng.Offset(-3, 0) 'remove any existing shapes for this range
For Each c In rng.Cells 'check each chsnged cell in the monitored range
c.Font.Color = vbRed
c.NumberFormat = "#"
PictureLoc = FLDR & c.text & ".jpeg"
If Len(Dir(PictureLoc)) > 0 Then 'does the file exist?
Set cPic = c.Offset(-3, 0) 'picture destination cell
With Me.Pictures.Insert(PictureLoc)
.Height = 119
.Width = 119
.Top = cPic.Top + cPic.Height / 2 - .Height / 2
.Left = cPic.Left + cPic.Width / 2 - .Width / 2
.Placement = xlMoveAndSize
End With
c.Font.Color = vbBlack
Else
c.Font.Color = vbRed 'flag file not found (or use msgbox)
End If
Next c
End Sub
'remove any shape whose topleftcell intersects with range `rng`
Sub RemovePics(rng As Range)
Dim i As Long
For i = Me.Shapes.Count To 1 Step -1 'step backwards if deleting
With Me.Shapes(i)
If Not Application.Intersect(.TopLeftCell, rng) Is Nothing Then .Delete
End With
Next i
End Sub
Thank you all for your help. There seemed to be a list of things I was doing g incorrectly (Including using Target instead of ActiveCell) but I finally got it to work. This is my current code
Function IsFile(ByVal fName As String) As Boolean
'Returns TRUE if the provided name points to an existing file.
'Returns FALSE if not existing, or if it's a folder
On Error Resume Next
IsFile = ((GetAttr(fName) And vbDirectory) <> vbDirectory)
End Function
Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range
Set KeyCells = Range("b7:e7,b13:e13,b19:e19,b25:e25,b31:e31,b37:e37")
Dim PictureLoc As String
Dim myPict As Picture
Dim ws As Worksheet
Target.NumberFormat = "#"
Dim imgcell As Range
Set imgcell = Target.Offset(-3, 0)
If Not Application.Intersect(KeyCells, Range(Target.Address)) Is Nothing Then
For Each sh In ActiveSheet.Shapes
If sh.TopLeftCell.Address = imgcell.Address Then sh.Delete
Next
If IsFile("\\amer.turck.info\data\Plymouth\Marketing\Asim Connectivity Image Project\Vending_poster\images\" & Target.Text & ".jpeg") = True Then
PictureLoc = "\\amer.turck.info\data\Plymouth\Marketing\Asim Connectivity Image Project\Vending_poster\images\" & Target.Text & ".jpeg"
ElseIf IsFile("\\amer.turck.info\data\Plymouth\Marketing\Asim Connectivity Image Project\Vending_poster\images\" & Target.Text & ".jpg") = True Then
PictureLoc = "\\amer.turck.info\data\Plymouth\Marketing\Asim Connectivity Image Project\Vending_poster\images\" & Target.Text & ".jpg"
ElseIf IsFile("\\amer.turck.info\data\Plymouth\Marketing\Asim Connectivity Image Project\Vending_poster\images\" & Target.Text & ".png") = True Then
PictureLoc = "\\amer.turck.info\data\Plymouth\Marketing\Asim Connectivity Image Project\Vending_poster\images\" & Target.Text & ".png"
End If
With imgcell
On Error GoTo errormessage:
Set myPict = ActiveSheet.Pictures.Insert(PictureLoc)
myPict.Height = 119
myPict.Width = 119
If myPict.Height > 119 Then
myPict.Height = 119
End If
myPict.Top = .Top + .Height / 2 - myPict.Height / 2
myPict.Left = .Left + .Width / 2 - myPict.Width / 2
myPict.Placement = xlMoveAndSize
errormessage:
If Err.Number = 1004 Then
MsgBox "File does not Exist, Please first update photo with .jpg File"
End If
End With
End If
End Sub
Also I apologize if this request was messy or disorganized. It is my first time posting on Stackoverflow/
I have a table that contains the file path, when the button is clicked the macro will display an image according to the url path. Here is my code (sourch : Link)
Sub Macro_1()
Dim cShape As Shape
Dim cRange As Range
Dim cColumn As Long
On Error Resume Next
Application.ScreenUpdating = False
Set xRange = ActiveSheet.Range("C5:D6, G5:H6, C8:D9, G8:H9")
For Each cell In xRange
cName = cell
ActiveSheet.Pictures.insert(cName).Select
Set cShape = Selection.ShapeRange.Item(1)
If cShape Is Nothing Then GoTo line22
cColumn = cell.Column
Set cRange = Cells(cell.Row, cColumn)
With cShape
.LockAspectRatio = msoFalse
.Height = cRange.Height - 5
.Width = cRange.Width - 5
.Top = cRange.Top + 2
.Left = cRange.Left + 2
.Placement = xlMoveAndSize
End With
line22:
Set cShape = Nothing
Next
Application.ScreenUpdating = True
End Sub
The code works as shown in the following illustration.
But I want the image to be in all merged cells. As shown in the following picture
Please let me know if you see anything that will fix this! I'm sure it's something simple, but I've been stuck for a while on this one.
You can use the MergeArea property of the Range object to return the merged range. Your macro can amended as follows (untested) . . .
Sub Macro_1()
Dim cShape As Shape
Dim cRange As Range
Dim cColumn As Long
On Error Resume Next
Application.ScreenUpdating = False
Set xRange = ActiveSheet.Range("C5, G5, C8, G8")
For Each cell In xRange
cName = cell
ActiveSheet.Pictures.Insert(cName).Select
Set cShape = Selection.ShapeRange.Item(1)
If cShape Is Nothing Then GoTo line22
cColumn = cell.Column
Set cRange = cell.MergeArea
With cShape
.LockAspectRatio = msoFalse
.Height = cRange.Height - 5
.Width = cRange.Width - 5
.Top = cRange.Top + 2
.Left = cRange.Left + 2
.Placement = xlMoveAndSize
End With
line22:
Set cShape = Nothing
Next
Application.ScreenUpdating = True
End Sub
I have been using the following code to insert images from the URL. If there is a URL in the cell, it pastes the image and if there is not then leaves a star image which is already in the document. It worked fine for a while, however suddenly the images no longer come across unless I open the URLs of each image beforehand which can be frustrating as sometime there is quite a lot (I did not have to open them beforehand).
I'm not sure if this is an issue with the code or possibly a setting that may be blocking the URL until it is opened. Any help would be appreciated.
Sub URLPictreInsert()
Dim shp As Shape
Dim Pshp As Shape
Dim xRg As Range
Dim xCol As Long
Dim Pic As Object
Dim lLeft As Long
Dim lTop As Long
On Error Resume Next
xCol = 2
Sheets("Message Template").Activate
Application.ScreenUpdating = False
For Each Pic In ActiveSheet.Pictures
Pic.Delete
Next Pic
For Each shp In ActiveSheet.Shapes
shp.Delete
Next shp
Set Rng = Sheets("First Class").Range("E5:E500")
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
Sheets("Message Template").Activate
Set xRg = Cells(2, xCol)
Pshp.Placement = xlMoveAndSize
With Pshp
.Width = 100
If Pshp.Height > xRg.Height Then Pshp.Height = xRg.Height
.Top = xRg.Top + (xRg.Height - .Height) / 2
.Left = xRg.Left + (xRg.Width - .Width) / 2
End With
GoTo 2
I am trying to extract an image from a URL and embed it in Excel.
My Excel Sheet is simple: it contains 2 columns.
Column 1 has the image URL. In column 2 I want to embed the image.
I am using the following code. It is working perfectly fine for first row where I have saved the image on my local machine and given the path, but it fails when trying to embed straight from the URL. I receive the following error:
Error - Run time 1004 , unable to get the insert property for the
picture class.
My code:
Sub Button1_Click()
'ActiveSheet.Pictures.Insert("C:\810CfHBPGyL._SX425_.jpg").Select
'Updateby Extendoffice 20161116
Dim Pshp As Shape
Dim xRg As Range
Dim xCol As Long
'On Error Resume Next
Application.ScreenUpdating = False
Set Rng = ActiveSheet.Range("A2:A3")
MsgBox "Step1"
For Each cell In Rng
filenam = cell
MsgBox "Step2" & cell
ActiveSheet.Pictures.Insert(filenam).Select
MsgBox "Step3"
Set Pshp = Selection.ShapeRange.Item(1)
'MsgBox "Step4" & Pshp
If Pshp Is Nothing Then GoTo lab
xCol = cell.Column + 1
Set xRg = Cells(cell.Row, xCol)
With Pshp
.LockAspectRatio = msoFalse
.Width = 80
.Height = 80
.Top = xRg.Top + (xRg.Height - .Height) / 2
.Left = xRg.Left + (xRg.Width - .Width) / 2
End With
lab:
Set Pshp = Nothing
Range("A2").Select
Next
Application.ScreenUpdating = True
End Sub
Could this be a problem with the Excel VBA references?