This code inserts a picture into my excel worksheet, from a specific folder, by entering the name of the picture into a cell. For example, if I was to enter a1.jpg into cell J4, I would then get an output of the image that I want from the folder to a cell that is one space to the right of J4.
The dilemma I'm having is that my excel template has various sized cells and I am trying to place the picture in a specific location but having a hard time. This is because the current code moves the picture by cells so if the cell is too long, the picture will be moved the whole length of the cell. I was wondering if this could be changed such that the image can be placed directly at a certain point and not designated by cells.
code credit goes to pokemon_Man
The code is as follows:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim imagePath, fileName, fullImagePath, newImageLoc As String
imagePath = "C:\YourFileLocationPath\"
If Target.Address = "$J$4" Then
fullImagePath = imagePath & Target.Value
newImageLoc = Target.Offset(, 1).Address
With ActiveSheet.Pictures.Insert(fullImagePath)
.Left = ActiveSheet.Range(newImageLoc).Left
.Top = ActiveSheet.Range(newImageLoc).Top
.Placement = 1
.PrintObject = True
End With
End
End If
End Sub
Try:
.Left = Target.Left + Target.Width / 2
.Top = Target.Top + Target.Height / 2
Related
I'm adding ".jpg" files to my Excel sheet with the code below :
'Add picture to excel
xlApp.Cells(i, 20).Select
xlApp.ActiveSheet.Pictures.Insert(picPath).Select
'Calgulate new picture size
With xlApp.Selection.ShapeRange
.LockAspectRatio = msoTrue
.Width = 75
.Height = 100
End With
'Resize and make printable
With xlApp.Selection
.Placement = 1 'xlMoveAndSize
'.Placement = 2 'xlMove
'.Placement = 3 'xlFreeFloating
.PrintObject = True
End With
I don't know what I am doing wrong but it doesn't get inserted into the right cell, so what should I do to put this picture into a specified cell in Excel?
Try this:
With xlApp.ActiveSheet.Pictures.Insert(PicPath)
With .ShapeRange
.LockAspectRatio = msoTrue
.Width = 75
.Height = 100
End With
.Left = xlApp.ActiveSheet.Cells(i, 20).Left
.Top = xlApp.ActiveSheet.Cells(i, 20).Top
.Placement = 1
.PrintObject = True
End With
It's better not to .select anything in Excel, it is usually never necessary and slows down your code.
Looking at posted answers I think this code would be also an alternative for someone. Nobody above used .Shapes.AddPicture in their code, only .Pictures.Insert()
Dim myPic As Object
Dim picpath As String
picpath = "C:\Users\photo.jpg" 'example photo path
Set myPic = ws.Shapes.AddPicture(picpath, False, True, 20, 20, -1, -1)
With myPic
.Width = 25
.Height = 25
.Top = xlApp.Cells(i, 20).Top 'according to variables from correct answer
.Left = xlApp.Cells(i, 20).Left
.LockAspectRatio = msoFalse
End With
I'm working in Excel 2013. Also realized that You need to fill all the parameters in .AddPicture, because of error "Argument not optional". Looking at this You may ask why I set Height and Width as -1, but that doesn't matter cause of those parameters are set underneath between With brackets.
Hope it may be also useful for someone :)
If it's simply about inserting and resizing a picture, try the code below.
For the specific question you asked, the property TopLeftCell returns the range object related to the cell where the top left corner is parked. To place a new image at a specific place, I recommend creating an image at the "right" place and registering its top and left properties values of the dummy onto double variables.
Insert your Pic assigned to a variable to easily change its name. The Shape Object will have that same name as the Picture Object.
Sub Insert_Pic_From_File(PicPath as string, wsDestination as worksheet)
Dim Pic As Picture, Shp as Shape
Set Pic = wsDestination.Pictures.Insert(FilePath)
Pic.Name = "myPicture"
'Strongly recommend using a FileSystemObject.FileExists method to check if the path is good before executing the previous command
Set Shp = wsDestination.Shapes("myPicture")
With Shp
.Height = 100
.Width = 75
.LockAspectRatio = msoTrue 'Put this later so that changing height doesn't change width and vice-versa)
.Placement = 1
.Top = 100
.Left = 100
End with
End Sub
Good luck!
I have been working on a system that ran on a PC and Mac and was battling to find code that worked for inserting pictures on both PC and Mac. This worked for me so hopefully someone else can make use of it!
Note: the strPictureFilePath and strPictureFileName variables need to be set to valid PC and Mac paths Eg
For PC: strPictureFilePath = "E:\Dropbox\" and strPictureFileName = "TestImage.jpg" and with Mac: strPictureFilePath = "Macintosh HD:Dropbox:" and strPictureFileName = "TestImage.jpg"
Code as Follows:
On Error GoTo ErrorOccured
shtRecipeBrowser.Cells(intDestinationRecipeRowCount, 1).Select
ActiveSheet.Pictures.Insert(Trim(strPictureFilePath & strPictureFileName)).Select
Selection.ShapeRange.Left = shtRecipeBrowser.Cells(intDestinationRecipeRowCount, 1).Left
Selection.ShapeRange.Top = shtRecipeBrowser.Cells(intDestinationRecipeRowCount, 1).Top + 10
Selection.ShapeRange.LockAspectRatio = msoTrue
Selection.ShapeRange.Height = 130
Firstly, of all I recommend that the pictures are in the same folder as the workbook.
You need to enter some codes in the Worksheet_Change procedure of the worksheet. For example, we can enter the following codes to add the image that with the same name as the value of cell in column A to the cell in column D:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim pic As Picture
If Intersect(Target, [A:A]) Is Nothing Then Exit Sub
On Error GoTo son
For Each pic In ActiveSheet.Pictures
If Not Application.Intersect(pic.TopLeftCell, Range(Target.Offset(0, 3).Address)) Is Nothing Then
pic.Delete
End If
Next pic
ActiveSheet.Pictures.Insert(ThisWorkbook.Path & "\" & Target.Value & ".jpg").Select
Selection.Top = Target.Offset(0, 2).Top
Selection.Left = Target.Offset(0, 3).Left
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.ShapeRange.Height = Target.Offset(0, 2).Height
Selection.ShapeRange.Width = Target.Offset(0, 3).Width
son:
End Sub
With the codes above, the picture is sized according to the cell it is added to.
Details and sample file here : Vba Insert image to cell
I tested both #SWa and #Teamothy solution. I did not find the Pictures.Insert Method in the Microsoft Documentations and feared some compatibility issues. So I guess, the older Shapes.AddPicture Method should work on all versions. But it is slow!
On Error Resume Next
'
' first and faster method (in Office 2016)
'
With ws.Pictures.Insert(Filename:=imageFileName, LinkToFile:=msoTrue, SaveWithDocument:=msoTrue)
With .ShapeRange
.LockAspectRatio = msoTrue
.Width = destRange.Width
.height = destRange.height '222
End With
.Left = destRange.Left
.Top = destRange.Top
.Placement = 1
.PrintObject = True
.Name = imageName
End With
'
' second but slower method (in Office 2016)
'
If Err.Number <> 0 Then
Err.Clear
Dim myPic As Shape
Set myPic = ws.Shapes.AddPicture(Filename:=imageFileName, _
LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, _
Left:=destRange.Left, Top:=destRange.Top, Width:=-1, height:=destRange.height)
With myPic.OLEFormat.Object.ShapeRange
.LockAspectRatio = msoTrue
.Width = destRange.Width
.height = destRange.height '222
End With
End If
I've been trying to fix this problem for a while. The following code inserts a picture from your choose to my excel document. It places the picture in cell B10 and resizes it to the height of one of my merged cells. Now the problem is that I can't get it centerd.
.Left = 35#
With the line above i can manually center one picture, but i want every other picture with other width's to be centerd aswell. Can anyone help me with this problem? The code below is what i've been using. Thanks in advance!
Sub Insert_Pic_Section_One()
Dim fileName1 As Variant
fileName1 = Application.GetOpenFilename(filefilter:="Tiff Files(*.tif;*.tiff),*.tif;*.tiff,JPEG Files (*.jpg;*.jpeg;*.jfif;*.jpe),*.jpg;*.jpeg;*.jfif;*.jpe,Bitmap Files(*.bmp),*.bmp", FilterIndex:=2, Title:="Choose picture", MultiSelect:=False)
If fileName1 = False Then
Exit Sub
Else
ActiveWorkbook.ActiveSheet.Select
Range("B10").Select
Dim picture1 As Object
Set picture1 = ActiveWorkbook.ActiveSheet.Pictures.Insert(fileName1)
With picture1
.Top = .Top
.Left = 35#
.Width = .Width
.Height = 233#
End With
End If
End Sub
No need to select anything. Because you use a merged cell you need to use .MergeArea otherwise it will only give you the height and width of the unmerged row and column.
Dim ws As Worksheet
Dim targetCell As Range
Dim picture1 As Picture
Set ws = ActiveSheet 'replace with actual worksheet if possible
Set targetCell = ws.Range("B10")
Set picture1 = ws.Pictures.Insert(fileName1)
With picture1
.Height = targetCell.MergeArea.Height 'set height first because width will change
.Top = targetCell.Top
.Left = targetCell.Left + (targetCell.MergeArea.Width - .Width) / 2
End With
I have this following code. I want to paste this copied Picture to a range which i select in Destinationsheet. However i only know how to set the Location by selecting .top , .left , .width , .height . Is there a way to paste this Picture in a selected range such as G30:J:30 ?
Windows(osman).Activate
Sheets("Overview").Range("A30:D37").CopyPicture
Dim DestinationSheet As Worksheet
Set DestinationSheet = Workbooks(anan).Sheets("Eingabefeld")
DestinationSheet.Paste
Dim pastedPic As Shape
Set pastedPic = DestinationSheet.Shapes(1)
With pastedPic
.Top = DestinationSheet.Cells(17, 2).Top
'Rest of positioning code here
End With
this code is very close to what I want,
I want to copy a range, as an image and insert it in a different sheet and size it to the outer boundries of a cell range.
All is well, apart from one ghlitch, when the routine runs the
"Set pastedPic = DestinationSheet.Shapes(1)" it picks up the last selected and the one before that object, ending in sizing the inserted picture and the shape before last...
the way I manage to get some consistant results, was to change (1) to (2) the one before that, which apparently seens to be the copied entity...
go figure...
I tested this and it worked for me. If you have a multicell range object you can get the width and height. If you don't change the .LockAspectRatio = msoFalse your picture may adjust itself.
Dim r As Range
Set r = Me.Range("G30:J30")
With pastedPic
.LockAspectRatio = msoFalse
.Top = r.Top
.Left = r.Left
.Width = r.Width
.Height = r.Height
End With
I tried you code this is what I came up with. For the copy picture line I actually copy a picture of the cells not a particular picture within those cells. Is that what you expected?
One other change was I used ThisWorkbook instead of your workbook index. Adjust as necessary
Sub test()
Dim pastedPic As Shape
Dim DestinationSheet As Worksheet
Dim desitinationRange As Range
Set DestinationSheet = ThisWorkbook.Sheets("Eingabefeld")
Sheets("Overview").Range("A30:D37").CopyPicture
DestinationSheet.Paste
Set pastedPic = DestinationSheet.Shapes(1)
Set desitinationRange = Me.Range("G30:J30")
With pastedPic
.LockAspectRatio = msoFalse
.Top = desitinationRange.Top
.Left = desitinationRange.Left
.Width = desitinationRange.Width
.Height = desitinationRange.Height
End With
End Sub
once copying the chart, can do this way:
Sheets("Sheet1").Select
Range("A1:H14").Select
ActiveSheet.Paste
ActiveChart.Parent.Width = Range("A1:H14").Width
ActiveChart.Parent.Height = Range("A1:H14").Height
I'm currently working on a project and need to fill in cells with pictures via URLs. All URLs are in one column, and I'd like to load the images in an adjacent column. I'm no VBA expert, but I found some code that worked, but for some reason I get an error (usually 5 images in) that says:
Run-time error '1004':
Unable to get the Insert property of the Pictures Class
Again, I'm using a system where URLs are in one column i.e.:
xxxx.com/xxxx1.jpg
xxxx.com/xxxx2.jpg
xxxx.com/xxxx3.jpg
xxxx.com/xxxx4.jpg
Through some searching, I found that it could be linked to my Excel version (using 2010), though I'm not completely sure.
Here's the current code I'm using:
Sub URLPictureInsert()
Dim cell, shp As Shape, target As Range
Set Rng = ActiveSheet.Range("a5:a50") ' range with URLs
For Each cell In Rng
filenam = cell
ActiveSheet.Pictures.Insert(filenam).Select
Set shp = Selection.ShapeRange.Item(1)
With shp
.LockAspectRatio = msoTrue
.Width = 100
.Height = 100
.Cut
End With
Cells(cell.Row, cell.Column + 1).PasteSpecial
Next
End Sub
Any help would be much appreciated!
Original code source: http://www.mrexcel.com/forum/excel-questions/659968-insert-image-into-cell-url-macro.html
This is an almost identical solution that I posted about a month ago:
Excel VBA Insert Images From Image Name in Column
Sub InsertPic()
Dim pic As String 'file path of pic
Dim myPicture As Picture 'embedded pic
Dim rng As Range 'range over which we will iterate
Dim cl As Range 'iterator
Set rng = Range("B1:B7") '<~~ Modify this range as needed. Assumes image link URL in column A.
For Each cl In rng
pic = cl.Offset(0, -1)
Set myPicture = ActiveSheet.Pictures.Insert(pic)
'
'you can play with this to manipulate the size & position of the picture.
' currently this shrinks the picture to fit inside the cell.
With myPicture
.ShapeRange.LockAspectRatio = msoFalse
.Width = cl.Width
.Height = cl.Height
.Top = Rows(cl.Row).Top
.Left = Columns(cl.Column).Left
End With
'
Next
End Sub
I know this thread is 5 years old but just wanted to say it really helped me with a project.
I'm using VBA to bring in data from an orders database. When I click on an order from those results it brings in more details about the orders including an image URL.
The problem I had was that the code above was designed to add the image in place of the URL. I wanted to replace the image from a previous query with the image from the new query. After some tweaks I got it working but it was just laying a new image on top of the old image. In time my Excel file could get really big so here's my solution. The only problem I have right now is that it deletes my company's logo that I put on the sheet. There may be a way to be more selective, or I could just change the procedure to insert the logo from another sheet in the workbook every time it deletes pictures but that seems a bit cheesy.
Sub InsertPic()
Dim productImageUrl As String
Dim productImage As Picture 'Declare image picture object
Dim productImageUrlRng As Range 'Declare range object to contain image URL
Dim productImageRng As Range 'Location image will be placed
'Delete any existing pictures:
Set productImageRng = ActiveSheet.Range("J1:J15") 'Where I want to put the image
Set productImageUrlRng = Range("BA2") 'Cell containing image URL
productImageUrl = productImageUrlRng
productImageRng.Select
'productImageRng.Delete --Does not delete pictures in range
ActiveSheet.Pictures.Delete 'Delete existing images
Set productImage = ActiveSheet.Pictures.Insert(productImageUrl)
With productImage
.ShapeRange.LockAspectRatio = msoTrue
'.Width = productImageRng.Width
.Height = productImageRng.Height
' .Top = Rows(cl.Row).Top
' .Left = Columns(cl.Column).Left
End With
End Sub
I have some cells with some values. This values are the names of a pictures in a folder. I would like to show the proper picture called "value" when I click a cell "value". I would like to do it dynamically, so that adding a picture causes displaying it when a cell with its name value is clicked. Could you tell me where should I start? Are there any tutorials showing how to do this? I found many, but they use lists and store pics in excel worksheet. Are there any examples?
Private Sub CommandButton2_Click()
On Error Resume Next
Dim imageFolder As String 'this is the folder where the image is located
Dim imagePath As String
Cells.Find("Code").Offset(1).Select
Range(Selection, Selection.End(xlDown)).Select
For Each cell In Selection
imageFolder = cell.Value
imagePath = "C:\Documents and Settings\kollol\My Documents\Quotes\Image\" & imageFolder
cell.Offset(0, 2).Select
ActiveSheet.Pictures.Insert(imagePath & "\" & "1.jpeg").Select ' here the name of the image is 1.jpg
With Selection
.Placement = xlMoveAndSize
.ShapeRange.LockAspectRatio = msoTrue
.ShapeRange.Width = ActiveCell.ColumnWidth
.ShapeRange.Height = ActiveCell.RowHeight - 5
.ShapeRange.IncrementLeft 10.5
.ShapeRange.IncrementTop 4#
End With
Next cell
End Sub