Macro to insert picture into a cell

[__Steve__]

Hi Excel Gurus

I am working on a macro allowing me to insert a picture into a cell activated with a button. I'd like to find out how this could be done. After clicking on a button "Insert Drawing" a generic windows dialog box should pop up asking me to select a picture I'd like to insert. After selecting required picture it would be inserted into a cell with resizing option to match cell width but locked aspect ration (cell height would adjust to keep original aspect ratio). Inserted picture need to be moving and scaling with cells. Please help

 

[__Steve__]

Ok, I got it working now. I,ve added a line to unhide the range when picture is inserted (initially I want the range to be hidden). Thank you for your time and effort.

Here's the code if anyone wants to use it:

Private Sub Insert_Pic1()
Application.ScreenUpdating = False
ActiveSheet.Rows("15:54").EntireRow.Hidden = False
Set rng = ActiveSheet.Range("B15:M54")
fName = Application.GetOpenFilename("Picture files (*.jpg;*.gif;*.bmp;*.tif), *.jpgs;*.gif;*.bmp;*.tif", , _
"Select picture to insert")
If fName = "False" Then Exit Sub
ActiveSheet.Pictures.Insert(fName).Select
With Selection.ShapeRange
.LockAspectRatio = msoFalse
.Width = 815
.Top = rng.Top
.Left = rng.Left
.Height = rng.Height
.Width = rng.Width
End With
Application.ScreenUpdating = True
End Sub

 

[__Steve__]

Ok, now something similar but instead of inserting a picture I would like to insert a PDF file. It's working fine but there is one little problem: I get an error in line .Placement=xlMoveAndSize
I would like the PDF drawing to move and size with cells.


Private Sub Insert_PDF1()
Application.ScreenUpdating = False
ActiveSheet.Rows("16:60").EntireRow.Hidden = False
Set rng = ActiveSheet.Range("B16:M60")
fName = Application.GetOpenFilename("PDF Files (*.pdf), *.pdf", Title:="Select PDF to insert")
If fName = "False" Then Exit Sub
ActiveSheet.OLEObjects.Add(Filename:=fName, Link:=False, DisplayAsIcon:=False).Select
With Selection.ShapeRange
.LockAspectRatio = msoTrue
.Width = 815
.Top = rng.Top
.Left = rng.Left
.Width = rng.Width
.Placement = xlMoveAndSize
.PrintObject = True
End With
Application.ScreenUpdating = True
End Sub

 

[patel45]

Private Sub Insert_PDF1()
Application.ScreenUpdating = False
ActiveSheet.Rows("16:60").EntireRow.Hidden = False
Set Rng = ActiveSheet.Range("B16:M60")
fName = Application.GetOpenFilename("PDF Files (*.pdf), *.pdf", Title:="Select PDF to insert")
If fName = "False" Then Exit Sub
ActiveSheet.OLEObjects.Add(Filename:=fName, Link:=False, DisplayAsIcon:=False).Select
With Selection.ShapeRange
.LockAspectRatio = msoTrue
.Top = Rng.Top
.Left = Rng.Left
.Width = Rng.Width
End With
Application.ScreenUpdating = True
End Sub

 

[__Steve__]

It's the same code as before apart from the line .Placement = xlMoveAndSize. I know when you remove it it will work, but inserted PDF will not move and scale with cells and I need that, that's why I'm trying to add this command.

Private Sub Insert_PDF1()
Application.ScreenUpdating = False
ActiveSheet.Rows("16:60").EntireRow.Hidden = False
Set Rng = ActiveSheet.Range("B16:M60")
fName = Application.GetOpenFilename("PDF Files (*.pdf), *.pdf", Title:="Select PDF to insert")
If fName = "False" Then Exit Sub
ActiveSheet.OLEObjects.Add(Filename:=fName, Link:=False, DisplayAsIcon:=False).Select
With Selection.ShapeRange
.LockAspectRatio = msoTrue
.Top = Rng.Top
.Left = Rng.Left
.Width = Rng.Width
End With
Application.ScreenUpdating = True
End Sub

 

[patel45]

Private Sub Insert_PDF1()
Set Rng = ActiveSheet.Range("B2:M20")
fName = Application.GetOpenFilename("PDF Files (*.pdf), *.pdf", Title:="Select PDF to insert")
If fName = "False" Then Exit Sub
ActiveSheet.OLEObjects.Add(Filename:=fName, Link:=False, DisplayAsIcon:=False).Select
With Selection
.Top = Rng.Top
.Left = Rng.Left
.Width = Rng.Width
.Placement = 1
End With
End Sub

 

[__Steve__]

No joy. Run-time error '438': Object doesn't support this property or method

Private Sub Insert_PDF1()
Set Rng = ActiveSheet.Range("B2:M20")
fName = Application.GetOpenFilename("PDF Files (*.pdf), *.pdf", Title:="Select PDF to insert")
If fName = "False" Then Exit Sub
ActiveSheet.OLEObjects.Add(Filename:=fName, Link:=False, DisplayAsIcon:=False).Select
With Selection
.Top = Rng.Top
.Left = Rng.Left
.Width = Rng.Width
.Placement = 1
End With
End Sub

 

[patel45]

This code works well on my excel 2010, wich line causes error ?

 

[__Steve__]

This code works well on my excel 2010, wich line causes error ?

I'm using Excel 2010 as well and get the error in line .Placement = 1

 

[patel45]

can you provide a link to a sample file ?

 

[__Steve__]

can you provide a link to a sample file ?

That's strange, when I created a new file and tested the code it worked perfect. If I want to use the very same code in my spreadsheet I get the error in line .Placement = 1

Run-time error '438': Object doesn't support this property or method