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
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 written a code to set pictures next to it's link in an excel sheet after it's done downloading. It is working smoothly but the problem is that every time i run the code it gets downloaded again and settled there. So if i delete one picture i see another one in that place. I hope there is a solution in if statement so that, if applied, it will omit downloading and go for the next loop if the cell is already filled in. I can't make it. If anybody helps me accomplish this, i would be very grateful. Thanks in advance.
Note: Links are in B column and pictures to get settled in C column.
Sub SetPics()
Dim pics As String
Dim myPic As Picture
Dim rng As Range
Dim cel As Range
Set rng = Range("C2", Range("B2").End(xlDown).Offset(0, 1))
For Each cel In rng
pics = cel.Offset(0, -1)
Set myPic = ActiveSheet.Pictures.Insert(pics)
With myPic
.ShapeRange.LockAspectRatio = msoFalse
.Width = cel.Width
.Height = cel.Height
.Top = Rows(cel.Row).Top
.Left = Columns(cel.Column).Left
End With
Next cel
End Sub
You need to scan the ActiveSheet (try not to use this, and replace it with Worksheets("YourSheetName")) for all Shapes.
For each Shape found, check it's TopLeftCell.Row property, if it equals the
cel.Row then the current picture already exists (from previous runs of this code), and you don't "re-insert" the picture.
Code
Sub SetPics()
Dim pics As String
Dim myPics As Shape
Dim PicExists As Boolean
Dim myPic As Picture
Dim rng As Range
Dim cel As Range
Set rng = Range("C2", Range("B2").End(xlDown).Offset(0, 1))
For Each cel In rng
PicExists = False ' reset flag
pics = cel.Offset(0, -1)
' loop through all shapes in ActiveSheet
For Each myPics In ActiveSheet.Shapes
If myPics.TopLeftCell.Row = cel.Row Then ' check if current shape's row equale the current cell's row
PicExists = True ' raise flag >> picture exists
Exit For
End If
Next myPics
If Not PicExists Then '<-- add new picture only if doesn't exist
Set myPic = ActiveSheet.Pictures.Insert(pics)
With myPic
.ShapeRange.LockAspectRatio = msoFalse
.WIDTH = cel.WIDTH
.HEIGHT = cel.HEIGHT
.Top = Rows(cel.Row).Top
.Left = Columns(cel.Column).Left
End With
End If
Next cel
End Sub
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
This is how I am inserting the picture: format it, cut it, paste it into the right cell and then grab it by the .top and .left. I've done it this way so that the picture will move with the rows when sorting (if I just .addpicture it won't get sorted).
...But now that I have solved the sorting problem, the .ClearComments started deleting the pictures instead of the comments. (It will also delete the comments, but it first deletes the pictures!)
Any ideas on how to solve this?
Dim myPicture as Picture
Dim pictShape as Shape
Dim oCell as Range
Set myPicture = ActiveSheet.Pictures.Insert("http://img.youtube.com/vi/" & VideoURL & "/default.jpg")
With myPicture
.ShapeRange.PictureFormat.CropTop = 7.96
.ShapeRange.PictureFormat.CropBottom = 8.225
.ShapeRange.LockAspectRatio = msoTrue
.Height = pixHeight
.Top = pixTop
.Left = pixLeft
End With
Set pictShape = ActiveSheet.Shapes(myPicture.Name)
pictShape.Cut
oCell.PasteSpecial
For Each Sh In ActiveSheet.Shapes
If Sh.Top = pixTop And Sh.Left = pixLeft Then 'found it!
Sh.Name = "Picture " & i
Exit For
End If
Next Sh
Set pictShape = ActiveSheet.Shapes("Picture " & i)
With pictShape
.Top = pixTop
.Left = pixTop
End With
Solved. Do not use .PasteSpecial on shapes when planing to use .ClearComments, instead use .Paste.
Set ExcSel = Selection ' save previous selection
oCell.Select ' select cell to paste to
ActiveSheet.Paste ' paste
ExcSel.Select ' select the originaly selected cell
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