inserting pictures

[gabethegrape]

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

 

[J Ericson]

Gabe,

This might not be the exact result you want but I tweak the code posted a little. I made the assumption that if the image is smaller than 206px x 206px that you wanted to enlarge the image to the max size without exceeding 206px. If you don't want images inlarged to your maximum allowable size, you may need to nest a few more if statements to get the desired results

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 = Selection    'Range("c21")
Set pic = ActiveSheet.Pictures.Insert(myPicture)


    If pic.Height > pic.Width Then
        With pic
            .Top = r.Top
            .Left = r.Left
            .ShapeRange.LockAspectRatio = msoCTrue
            .Height = 206
            .Placement = xlMoveAndSize
        End With
    ElseIf pic.Width > pic.Height Then
        With pic
            .Top = r.Top
            .Left = r.Left
            .ShapeRange.LockAspectRatio = msoCTrue
            .Width = 206
            .Placement = xlMoveAndSize
        End With
    End If

End If
End Sub

HTH,
J Ericson

 

[gabethegrape]

Thanks, J! That worked really well. I just added one more condition for pictures of equal size:

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 = Selection 'Range("c21")
Set pic = ActiveSheet.Pictures.Insert(myPicture)


If pic.Height > pic.Width Then
With pic
.Top = r.Top
.Left = r.Left
.ShapeRange.LockAspectRatio = msoCTrue
.Height = 206
.Placement = xlMoveAndSize
End With
ElseIf pic.Width > pic.Height Then
With pic
.Top = r.Top
.Left = r.Left
.ShapeRange.LockAspectRatio = msoCTrue
.Width = 206
.Placement = xlMoveAndSize
End With
ElseIf pic.Height = pic.Width Then
With pic
.Top = r.Top
.Left = r.Left
.ShapeRange.LockAspectRatio = msoCTrue
.Height = 206
.Placement = xlMoveAndSize
End With
End If

End If
End Sub