VBA Code/Macro for Sizing A Picture to a Range of Cells

Problem Description:

How do I have my VBA "measure the size of my active cell" then size the picture to fit the size of that cell.

I have a form used for creating work instructions. inside the form I have a macro to insert a picture. The issue I am having, is that I have the macro set to size the picture to a fixed size. Unfortionatly when other people use the form on their computers the picture no longer fits the cells like it does on mine.

Current State Description:

The macro inserts the picture into the merged cell that you have selected when you trigger the macro.

for example if I am in the top row of my form and want to insert a picture I would click into the merged section of 8B:8G and hit control-Z to trigger the macro. if I want to insert the picture into the second row of my form I would click into 9B:9G. etc.

Here is the current code I am using.

Sub Add_Picture()

'Chris Swier

'Unprotect sheet and turn screen updating off
Application.ScreenUpdating = False
ActiveSheet.Unprotect

'Find picture
Picture1 = Application.GetOpenFilename("Picture,*.JPG,Picture,*.JPEG,Picture,*.GIF,Picture,*.BMP")
'edit "("Picture,*.*")" section to add or change visible file types

'Insert picture into active cell
ActiveSheet.Pictures.Insert(Picture1).Select
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.ShapeRange.Height = 183
Selection.ShapeRange.Width = 265

'Remove picture link and insert picture file
Selection.CopyPicture
Selection.Delete
ActiveSheet.Paste

'Reprotect sheet and turn screen updating back on
Application.ScreenUpdating = True
ActiveSheet.Protect

End Sub

Thanks Tehnexus, the code works well,

The only thing I changed was the logic for picture sizing so that the picture sizes to the exact borders of the cell regaurdless of the initial size.

.LockAspectRatio = msoFalse
If .Width > .Height Then
.Width = xlRng.Width
If .Height <> xlRng.Height Then .Height = xlRng.Height
Else
.Height = xlRng.Height
If .Width <> xlRng.Width Then .Width = xlRng.Width
End If

What is the purpose of the two following lines?

.Placement = xlMoveAndSize
.PrintObject = True
Thanks,

CS

Been looking for something like this for a while and works 99%! One question, when the window pops up to select a picture from folders and you decide to cancel, the macro throws up and error at "ActiveSheet.Pictures.Insert(Picture1).Select". I am drawing a blank tonight as to how to prevent that from happening. Need an out, if you could help or someone out there? Thanks!