gabethegrape
New Member
- Joined
- Mar 3, 2009
- Messages
- 38
I've got the following macro to insert pictures into a worksheet. I want it to do the following:
1. Keep the picture within a maximum size parameter (206 x 206)
2. If picture height is greater than picture width, minimize picture height to 206 and keep width ratio.
3. If picture width is greater than picture height, minimize picture width to 206 and keep width ratio.
My current macro only preserves the height. It works for pictures that are taller than they are wider. If I add width parameter to the code then it compresses the picture (which I don't want).
Can anyone help me out??
Cheers,
Gabe
Sub InsertPicture2()
Dim myPicture As String
Dim pic As Picture
myPicture = Application.GetOpenFilename _
("Pictures (*.gif; *.jpg; *.bmp; *.tif),*.gif; *.jpg; *.bmp; *.tif", , "Select Picture to Import")
If myPicture = "False" Then Exit Sub
If myPicture <> "" Then
Set r = Range("c21")
Set pic = ActiveSheet.Pictures.Insert(myPicture)
With pic
.Top = r.Top
.Left = r.Left
.ShapeRange.LockAspectRatio = msoFalse
.Height = 206
.Placement = xlMoveAndSize
End With
End If
End Sub
1. Keep the picture within a maximum size parameter (206 x 206)
2. If picture height is greater than picture width, minimize picture height to 206 and keep width ratio.
3. If picture width is greater than picture height, minimize picture width to 206 and keep width ratio.
My current macro only preserves the height. It works for pictures that are taller than they are wider. If I add width parameter to the code then it compresses the picture (which I don't want).
Can anyone help me out??
Cheers,
Gabe
Sub InsertPicture2()
Dim myPicture As String
Dim pic As Picture
myPicture = Application.GetOpenFilename _
("Pictures (*.gif; *.jpg; *.bmp; *.tif),*.gif; *.jpg; *.bmp; *.tif", , "Select Picture to Import")
If myPicture = "False" Then Exit Sub
If myPicture <> "" Then
Set r = Range("c21")
Set pic = ActiveSheet.Pictures.Insert(myPicture)
With pic
.Top = r.Top
.Left = r.Left
.ShapeRange.LockAspectRatio = msoFalse
.Height = 206
.Placement = xlMoveAndSize
End With
End If
End Sub