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
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 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 would like to have my image properly resized and bordered with the black line, thickness 1.
My situation looks like this:
and when I used this code:
Sub ResizeCivilsA()
SizeToRange Sheets("Civils 1").Pictures("Picture 29"), Range("B3:L46")
End Sub
Function SizeToRange(s, Target As Range)
s.Left = Target.Left + 10
s.Top = Target.Top - 5
s.Width = Target.Width
s.Height = Target.Height
End Function
, everything was adjusted fine, but:
It have been done only for the specified shape id, which is "Picture 29"
It was without the borders
So I tried then:
Sub ResizeCivilsA()
Dim shp As Shape
For Each shp In ThisWorkbook.Worksheets
If shp.Name Like "*Picture*" Then
SizeToRange shp, Range("B3:L46")
End If
Next
and finally I am getting error:
Type mismatch, with debugger pointing the line:
For Each shp In ThisWorkbook.Worksheets
Regarding the border around the image I found the common solution here:
https://learn.microsoft.com/en-us/office/vba/api/Excel.Range.BorderAround
However after appliance into my work:
Worksheets("Civils 1").Shape("Picture 29").BorderAround _
ColorIndex:=3, Weight:=xlThick
it wasn't enough since I had to remove the _ and got nothing afterward.
Is there some way to have the possibility for instant resizing the image and making the border around it for ANY attached image, which as default is called "Picture..."?
Try this code.
Read code's comments and adjust it to fit your needs
EDIT: The code checks if picture is within target range ad then adjusts its properties.
Code:
Option Explicit
Public Sub ResizeAllShapesInSheet()
Dim targetSheet As Worksheet
Dim targetRange As Range
Dim targetShape As Shape
' Define the sheet that has the pictures
Set targetSheet = ThisWorkbook.Worksheets("Civils 1")
' Define the range the images is going to fit
Set targetRange = targetSheet.Range("B3:L46")
' Loop through each Shape in Sheet
For Each targetShape In targetSheet.Shapes
' Check "picture" word in name
If targetShape.Name Like "*Picture*" Then
' Call the resize function
SizeToRange targetShape, targetRange
End If
Next targetShape
End Sub
Private Sub SizeToRange(ByVal targetShape As Shape, ByVal Target As Range)
If Not (targetShape.Left >= Target.Left And _
targetShape.Top >= Target.Top And _
targetShape.Left + targetShape.Width <= Target.Left + Target.Width And _
targetShape.Top + targetShape.Height <= Target.Top + Target.Height) Then Exit Sub
' Adjust picture properties
With targetShape
' Check if next line is required...
.LockAspectRatio = msoFalse
.Left = Target.Left + 10
.Top = Target.Top - 5
.Width = Target.Width
.Height = Target.Height
End With
' Adjust picture border properties
With targetShape.Line
.Visible = msoTrue
.ForeColor.RGB = RGB(0, 0, 0)
.ForeColor.TintAndShade = 0
.ForeColor.Brightness = 0
.Transparency = 0
.Visible = msoTrue
.Weight = 6
End With
End Sub
Let me know if it works
Initial read looks like your For Each is looking for Shape objects, but you are giving it a collection of Sheet objects.
For Each sht In ThisWorkbook.Worksheets
For Each shp In sht.Shapes
If shp.Name Like "*Picture*" Then
Set r1 = shp.TopLeftCell
Set r2 = r1.Offset(10, 43)
SizeToRange shp, Range(r1.Address & ":" & r2.Address)
End If
Next shp
Next sht
Hope that helps!
EDIT: Updated with relative address.
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 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?