Lock Aspect Ratio - portrait, one line of code needed, quick fix

[micksid]

below is my coding, it inserts a picture into a cell and fits to what ever the cell size is.

my cells are more landscape (fixed) than portrait, how can i still make the images fit into the cell height wise but keep a aspect ratio of a portrait picture if you get me

Sub InsertPicture1()
Dim myPicture As Variant
myPicture = Application.GetOpenFilename _
("Pictures (*.gif; *.jpg; *.bmp; *.tif),*.gif; *.jpg; *.bmp; *.tif", , "Select Picture to Import")
If myPicture = False Then Exit Sub
Application.ScreenUpdating = False
Dim iLeft#, iTop#, iWidth#, iHeight#
With Range("B4")
iLeft = .Left
iTop = .Top
.Select
End With
Set myPicture = ActiveSheet.Pictures.Insert(myPicture)
With Range("b4")
iWidth = .Width: iHeight = .Height
End With
With myPicture
.Width = iWidth: .Height = iHeight
End With
Application.ScreenUpdating = True
Dim octl As CommandBarControl
With Selection
Set octl = Application.CommandBars.FindControl(ID:=6382)
Application.SendKeys "%e~"
Application.SendKeys "%a~"
Application.SendKeys "%w~"
octl.Execute
End With
End Sub

 

[Andrew Poulsom]

Why are you setting the width? Try:

    With myPicture
        .ShapeRange.LockAspectRatio = msoTrue
        .Height = iHeight
    End With

 

[micksid]

Why are you setting the width? Try:

    With myPicture
        .ShapeRange.LockAspectRatio = msoTrue
        .Height = iHeight
    End With

thanks for that, it was some coding i found on the net and it worked ok, apart from the aspect ratio
can you modify my above code and put your bit into mine, ive tried putting it in, but it stretches the pic

so ive prob put it in the worng place

thanks

 

[Andrew Poulsom]

Try this:

Sub InsertPicture1()
    Dim myPicture As Variant
    myPicture = Application.GetOpenFilename _
        ("Pictures (*.gif; *.jpg; *.bmp; *.tif),*.gif; *.jpg; *.bmp; *.tif", , "Select Picture to Import")
    If myPicture = False Then Exit Sub
    Application.ScreenUpdating = False
    Dim iLeft#, iTop#, iWidth#, iHeight#
    With Range("B4")
        iLeft = .Left
        iTop = .Top
        .Select
    End With
    Set myPicture = ActiveSheet.Pictures.Insert(myPicture)
    With Range("b4")
        iWidth = .Width: iHeight = .Height
    End With
    With myPicture
        .ShapeRange.LockAspectRatio = msoFalse
        .Width = .Width * iHeight / .Height
        .Height = iHeight
    End With
    Application.ScreenUpdating = True
    Dim octl As CommandBarControl
    With Selection
        Set octl = Application.CommandBars.FindControl(ID:=6382)
        Application.SendKeys "%e~"
        Application.SendKeys "%a~"
        Application.SendKeys "%w~"
        octl.Execute
    End With
End Sub

 

[micksid]

thats works a treat thank you very much

dont suppose you know if you can centre the picture in the cells. at the moment it goes (top left) and you make it (Top Centre)

cheers

oh and this may be a stupid question, and i have tried it but it doesnt change automatically. i want to copy what ever is in cell a1 on sheet 1 to cell a1 on sheet 2.

i have done =sheet!A1 but it doesnt update automatically.. the cells will contain text

 

[Andrew Poulsom]

To centre the picture:

    With myPicture
        .ShapeRange.LockAspectRatio = msoFalse
        .Width = .Width * iHeight / .Height
        .Height = iHeight
        .Left = .Left + (iWidth - .Width) / 2
    End With

Your formula should update automatically if calculation is set to automatic. Otherwise you will need to press F9 when Calculate appears in the Status Bar.

 

[micksid]

perfect!!!!!! thankyou for your help