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?
Related
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 want to import multiple images based on filepath present in a "C" column. Jpeg Files are in a folder name "FolderOf_Images" and Upon running the code it does nothing and also no error was thrown. Surprisingly it worked only once and all pictures were imported in "D" column.
Image files will be placed in D Column. The source code I have tried is below without success.
Google driver Excel File Link
Sub InsertPicsIntoExcel()
'Pictures saved with file
'Set column width (ie, pic width) before running macro
Application.ScreenUpdating = False
Dim r As Range, Shrink As Long
Dim shp As Shape
Shrink = 0 'Provides negative offset from cell borders when > 0
On Error Resume Next
''''Delete existing shapes/pictures
For Each shp In ActiveSheet.Shapes
shp.Delete
Next shp
ActiveSheet.Rows.AutoFit
''''Insert shapes/pictures
For Each r In Range("C1:C" & Cells(Rows.Count, 1).End(xlUp).Row)
If r.Value <> "" Then
Set shp = ActiveSheet.Shapes.AddPicture(Filename:=r.Value, linktofile:=msoFalse, _
savewithdocument:=msoTrue, Left:=Cells(r.Row, "D").Left + Shrink, _
Top:=Cells(r.Row, "D").Top + Shrink, Width:=-1, Height:=-1)
With shp
.LockAspectRatio = msoTrue
.Width = Columns(2).Width - (2 * Shrink)
Rows(r.Row).RowHeight = .Height + (2 * Shrink)
End With
End If
Next r
Application.ScreenUpdating = True
MoveAndSizeWithCells
MsgBox ("Images Import Complete.")
End Sub
Sub MoveAndSizeWithCells()
Dim xPic As Picture
On Error Resume Next
Application.ScreenUpdating = False
For Each xPic In ActiveSheet.Pictures
xPic.Placement = xlMoveAndSize
Next
Application.ScreenUpdating = True
End Sub
I have made an excel macro for my company that mass inserts images in a picture folder by their cell value.
The cell.Value contains the SKU number, so I add the rest of the file path in a for each loop and then use ActiveSheet.Pictures.Insert(Filename).Select.
Everything works great, but when files are not found within the picture folder, the filepath is left in the cell. I would like to change all cells that don't find an image to say "No Image" rather than the filepath.
Is there anyway to test if ActiveSheet.Pictures.Insert(Filename).Select failed to find an image, then I could rewrite the cell.Value if it failed?
I've tried to add another For each loop to see if the cell.Value has contents in it. This is because the insert image portion runs a cell.ClearContents once it's done so all the cells with images inserted don't have their SKU numbers behind the image. I'm having trouble with this process as well and would like to avoid for eaching through the selection twice.
Option Explicit
Dim rng As Range
Dim cell As Range
Dim Filename As String
Sub PictureImport()
Set rng = ActiveSheet.Range("A2:A3000")
For Each cell In Selection '<-- *For Each cell In rng* For Hard Coded selection
If cell.Value <> "" Then cell.Value = "\\Pictures\" & cell.Value & ".jpg" '<---NEEDS TO SKIP HEADER
Next
Dim theShape As Shape
Dim xRg As Range
Dim xCol As Long
On Error Resume Next
Application.ScreenUpdating = False
Set rng = ActiveSheet.Range("A2:A3000") ' <---- CHANGE TO START AT A2 TO SKIP HEADER
For Each cell In Selection
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
Set xRg = Cells(cell.Row, xCol)
With theShape
.LockAspectRatio = msoFalse
' 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
cell.ClearContents
isnill:
Set theShape = Nothing
Range("A2").Select
End If
Next
Debug.Print "Done " & Now
Application.ScreenUpdating = True
End Sub
Actual Results as stands: Images in the pictures folder will be inserted to the size of the cell, but will leave the cells that could not find a picture with the file path still in the the cell value.
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