Move a picture with a vba macro

[Secret Squirrel]

I'm using this code to insert a picture and resize it to the currently
selected cell. The problem is that the picture resizes but doesn't center in
the selected cell. How can I add this to my code so that picture will center
to the selected cell?

Sub InsertPicture()

Dim myPicture As String

myPicture = Application.GetOpenFilename _
("Pictures (*.gif; *.jpg; *.bmp; *.tif),*.gif; *.jpg; *.bmp; *.tif", ,
"Select Picture to Import")
If myPicture <> "" Then
ActiveSheet.Pictures.Insert (myPicture)
ActiveSheet.Shapes(ActiveSheet.Shapes.Count).Select

With Selection

..ShapeRange.LockAspectRatio = msoFalse
..ShapeRange.Height = ActiveCell.RowHeight
..ShapeRange.Width = ActiveCell.ColumnWidth * 5.25 + 4
..Placement = xlMoveAndSize


End With
End If
End Sub

 

[Secret Squirrel]

Not sure I follow you. Right now when I run this macro it does what I want
and inserts the picture and sizes it to the height/width of the selected cell
but it doesn't put the picture in that cell. I have drag it to the cell. I
would much rather have the code put it in the cell automatically.

 

[Joel]

Picture are shapes which sit on top of a cell and not in the cell. To allign
a picture to a cell you have to use pixels. Both shapes and cells have the
location of their top left corner in pixels as parameter called .LEFT and
..RIGHT. If you want the picture to move to a cell then use the following:

ShapeRange.Top = activecell.Top
ShapeRange.Left = activecell.Right

Ther is a small border around each cell. The picture may be slightly off
center of the cell because of the border. That is why I posted my last code,
I didn't rrealize the picture wasn't located where you wanted to put it. One
caution, if you rezie the column width or row height the picture will not
move and will not be centered on the same cell.

 

[Secret Squirrel]

I added that to my code but now I'm getting an error, "Object doesn't support
this property or method".
Here's what the code looks like with your added code.

Sub InsertPicture()

Dim myPicture As String

myPicture = Application.GetOpenFilename _
("Pictures (*.gif; *.jpg; *.bmp; *.tif),*.gif; *.jpg; *.bmp; *.tif", ,
"Select Picture to Import")
If myPicture <> "" Then
ActiveSheet.Pictures.Insert (myPicture)
ActiveSheet.Shapes(ActiveSheet.Shapes.Count).Select

With Selection

..ShapeRange.LockAspectRatio = msoFalse
..ShapeRange.Height = ActiveCell.RowHeight
..ShapeRange.Width = ActiveCell.ColumnWidth * 5.25 + 4
..ShapeRange.Top = ActiveCell.Top
..ShapeRange.Left = ActiveCell.Right
..Placement = xlMoveAndSize


End With
End If
End Sub

 

[Joel]

You don't need shape range

Sub InsertPicture()

Dim myPicture As String

myPicture = Application.GetOpenFilename _
("Pictures (*.gif; *.jpg; *.bmp; *.tif),*.gif; *.jpg; *.bmp; *.tif", ,
"Select Picture to Import")
If myPicture <> "" Then
ActiveSheet.Pictures.Insert (myPicture)
ActiveSheet.Shapes(ActiveSheet.Shapes.Count).Select

With Selection

..ShapeRange.LockAspectRatio = msoFalse
..Height = ActiveCell.RowHeight
..Width = ActiveCell.ColumnWidth * 5.25 + 4
..Top = ActiveCell.Top
..Left = ActiveCell.Right
..Placement = xlMoveAndSize


End With
End If
End Sub

 

[Secret Squirrel]

Still getting that same error message. But after I click OK on the error it
places the picture in another cell.

 

[Joel]

There is no such thing as right, should of been left

from
..Left = ActiveCell.right
to
..Left = ActiveCell.Left

 

[Secret Squirrel]

Works perfectly! Thanks for your help!

There is no such thing as right, should of been left

from
.Left = ActiveCell.right
to
.Left = ActiveCell.Left

 

[Jon Peltier]

Make it run a little more smoothly by not selecting the picture:

Sub InsertPicture()

Dim myPicture As String

myPicture = Application.GetOpenFilename _
("Pictures (*.gif; *.jpg; *.bmp; *.tif),*.gif; *.jpg; *.bmp; *.tif", ,
_
"Select Picture to Import")
If Len(myPicture) > 0 Then
ActiveSheet.Pictures.Insert (myPicture)
With ActiveSheet.Shapes(ActiveSheet.Shapes.Count)

.LockAspectRatio = msoFalse
.Height = ActiveCell.RowHeight
.Width = ActiveCell.ColumnWidth * 5.25 + 4
.Top = ActiveCell.Top
.Left = ActiveCell.Right
.Placement = xlMoveAndSize

End With
End If
End Sub

Also I think this will not work uniformly if you change font, font size, and
font style (bold, italic):

.Width = ActiveCell.ColumnWidth * 5.25 + 4

Instead try this:

.Width = ActiveCell.Width

You can also just use .Height instead of .RowHeight.

- Jon