使用Excel VBA縮放圖片

Question

我正在嘗試縮放圖片以適合高度為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

有些圖片的原始格式在高度和寬度方面都有很大的尺寸。 我需要比例因子以更靈活。

Answer 1

找到了一種縮放圖片以捕捉單元格邊界的方法。

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