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

在Excel VBA中缩放图片

1 个答案: