使用Excel VBA缩放图片

Question

I'm trying to scale pictures to fit on a cell of height 172.75.

If sPhoto > -1 Then
    x.RowHeight = AltRow + x.Font.Size + 2

    On Error GoTo IsError

    factor = CSng(AltRow / Selection.ShapeRange.Height)
    If factor > CSng(x.Width / Selection.ShapeRange.Width) Then
        factor = CSng(x.Width / Selection.ShapeRange.Width)
    End If

    If factor < 0.5 Then
        factor = factor / 3.8
    End If

    With Selection
        .ShapeRange.LockAspectRatio = msoTrue
        .ShapeRange.ScaleWidth factor, msoTrue, msoScaleFromTopLeft
        .ShapeRange.ScaleHeight factor, msoTrue, msoScaleFromTopLeft
        .ShapeRange.Top = x.Top
        .ShapeRange.Left = x.Left
    End With
End If

Some pictures have a really big size in terms of height and width in their original format. I need the scale factor to more flexible.

Answer 1

Found a way to scale the pictures to snap to the bounds of the cell.

Dim AspectRatio As Double
Dim W, H As DoubleI

if SketchPhoto > -1 Then
  x.RowHeight = AltRow + x.Font.Size + 2 'Adjusting height to fit the picture for each cell

 With Selection.ShapeRange
    .LockAspectRatio = msoTrue
    AspectRatio = .Width / .Height
    .Left = x.Left
    .Top = x.Top
    W = x.Width      ' width of cell range
    H = x.Height     ' height of cell range
    If (W / H < AspectRatio) Then
        .Width = W - x.Font.Size + 0.5   ' scale picture to available width
    Else
        .Height = H - x.Font.Size + 0.5  ' scale picture to available height
    End If
    Range("A1").Activate
 End With
End If