Excel 在保持纵横比的同时调整图片大小

我想调整图像大小，保持纵横比

Public Sub ResizeCab2()

Dim targetSheet As Worksheet
Dim targetRange As Range
Dim targetShpe As Shape

' Define the sheet that has the pictures
Set targetSheet = ThisWorkbook.ActiveSheet
' Define the range the images is going to fit
Set targetRange = targetSheet.Range("B3:K24")

' Loop through each Shape in Sheet
For Each targetShape In targetSheet.Shapes

    ' Check "picture" word in name
    If targetShape.Name Like "*Picture*" Then
        ' Call the resize function
        SizeToRange targetShape, targetRange
    End If

Next targetShape

Call CableOddEven

End Sub

TargetSheet.Range

表示图像必须限定在前面指定的范围内。这意味着，当图像大小不符合Excel中的范围时，我的图像被扭曲了

如果我取下范围，并将其限制在一个单元格内，如下面的代码所示：

Public Sub ResizeCab2()

    Dim targetSheet As Worksheet
    Dim targetRange As Range
    Dim targetShpe As Shape
    
    ' Define the sheet that has the pictures
    Set targetSheet = ThisWorkbook.ActiveSheet
    ' Define the range the images is going to fit
    Set targetRange = targetSheet.Range("B3")
    
    ' Loop through each Shape in Sheet
    For Each targetShape In targetSheet.Shapes

        ' Check "picture" word in name
        If targetShape.Name Like "*Picture*" Then
            ' Call the resize function
            SizeToRange targetShape, targetRange
        End If

    Next targetShape
    
End Sub

然后我只在这个单元中得到图像

这是两个代码附带的功能：

Private Sub SizeToRange(ByVal targetShape As Shape, ByVal Target As Range)

    ' Adjust picture properties
    With targetShape
        ' Check if next line is required...
        .LockAspectRatio = msoTrue
        .Left = Target.Left + 10
        .Top = Target.Top - 4
        .Width = Target.Width - 20
        .Height = Target.Height
        .ZOrder msoSendToBack
    End With

    ' Adjust picture border properties
    With targetShape.Line
        .Visible = msoTrue
        .ForeColor.RGB = RGB(0, 0, 0)
        .ForeColor.TintAndShade = 0
        .ForeColor.Brightness = 0
        .Transparency = 0
        .Visible = msoTrue
        .Weight = 1
    End With

End Sub

我还对此函数做了一些小改动，替换了：

        .Left = Target.Left + 10
        .Top = Target.Top - 4

与

但即使使用

.LockAspectRatio=msoTrue

，也没有效果

---

我不需要这些图像被扭曲。我希望它们粘贴到由一个单元格表示的一个（即左上角）角。

您好，不确定，但您是否可以尝试仅修改“高度”属性？（我的意思是删除.Width=Target.Width-20）。很难保持一个比例，同时设置高度和宽度。让我知道：）是的，我想这是你的一个很好的暗示。我关掉了靶子。宽度和靶子。高度。我想现在效果很好。谢谢。您好，我不确定，但您能尝试只修改高度属性吗？（我的意思是删除.Width=Target.Width-20）。很难保持一个比例，同时设置高度和宽度。让我知道：）是的，我想这是你的一个很好的暗示。我关掉了靶子。宽度和靶子。高度。我想现在效果很好。非常感谢。

         .Top = Range("B3").Top
        .Left = Range("B3").Left