Vba 在Excel中嵌入并调整图像大小，保持纵横比

我正在尝试为Excel编写一个VBA宏来嵌入和调整图像大小，以保持纵横比。我想嵌入而不是链接，这样Excel文件可以在计算机之间共享

我有两段代码

1st将嵌入图像（SaveWithDocument），定位图像并更改高度（但不保持纵横比）

第二个将链接图像，放置图像并更改高度（保持纵横比）。此选项不会嵌入图像

Sub Button7_Click()

With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = False
        .ButtonName = "Submit"
        .Title = "Select an image file"
        .Filters.Clear
        .Filters.Add "JPG", "*.JPG"
        .Filters.Add "JPEG File Interchange Format", "*.JPEG"
        .Filters.Add "Graphics Interchange Format", "*.GIF"
        .Filters.Add "Portable Network Graphics", "*.PNG"
        .Filters.Add "Tag Image File Format", "*.TIFF"
        .Filters.Add "All Pictures", "*.*"

        If .Show = -1 Then

With ActiveSheet.Pictures.Insert(.SelectedItems(1))
    .ShapeRange.lockaspectratio = msoTrue
    .Left = 1050
    .Top = 35
    .Height = 150
End With

Else
            MsgBox ("No picture inserted")
        End If
    End With

End Sub

虽然这两段代码分别工作得很好，但我无法将它们结合起来。我知道“SaveWithDocument”不适用于“Pictures.Insert”和“LockAspectRatio”不适用于“Shapes.AddPicture”

有人能提供一些指导吗

---

非常感谢。

如果您分两步操作，我认为它会起作用，即插入原始大小的图像并设置LockAspectRatio，然后调整其大小

Set pic = ActiveSheet.Shapes.AddPicture(.SelectedItems(1), _
    LinkToFile:=msoFalse, _
    SaveWithDocument:=msoCTrue, _
    Left:=1050, _
    Top:=35, _
    Width:=-1, _
    Height:=-1).LockAspectRatio = msoTrue
pic.Height = 150

---

现在似乎已经解决了，而且效果很好。非常感谢你的帮助

Sub Button7_Click()

With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = False
        .ButtonName = "Submit"
        .Title = "Select an image file"
        .Filters.Clear
        .Filters.Add "JPG", "*.JPG"
        .Filters.Add "JPEG File Interchange Format", "*.JPEG"
        .Filters.Add "Graphics Interchange Format", "*.GIF"
        .Filters.Add "Portable Network Graphics", "*.PNG"
        .Filters.Add "Tag Image File Format", "*.TIFF"
        .Filters.Add "All Pictures", "*.*"

        If .Show = -1 Then

        Dim pic As Shape
        Set pic = ActiveSheet.Shapes.AddPicture(.SelectedItems(1), _
           LinkToFile:=msoFalse, _
         SaveWithDocument:=msoCTrue, _
         Left:=1050, _
         Top:=35, _
         Width:=-1, _
         Height:=-1)
      pic.lockaspectratio = msoTrue
      pic.Height = 150

      Else
        MsgBox ("No picture inserted")
       End If

End With

End Sub

---

非常感谢你的回复。不幸的是，我得到了一个运行时错误'13'。在此代码中替换时类型不匹配。这可能是因为我试图以不同的格式处理高度值两次吗？

Sub Button7_Click()

With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = False
        .ButtonName = "Submit"
        .Title = "Select an image file"
        .Filters.Clear
        .Filters.Add "JPG", "*.JPG"
        .Filters.Add "JPEG File Interchange Format", "*.JPEG"
        .Filters.Add "Graphics Interchange Format", "*.GIF"
        .Filters.Add "Portable Network Graphics", "*.PNG"
        .Filters.Add "Tag Image File Format", "*.TIFF"
        .Filters.Add "All Pictures", "*.*"

        If .Show = -1 Then

        Dim pic As Shape
        Set pic = ActiveSheet.Shapes.AddPicture(.SelectedItems(1), _
           LinkToFile:=msoFalse, _
         SaveWithDocument:=msoCTrue, _
         Left:=1050, _
         Top:=35, _
         Width:=-1, _
         Height:=-1)
      pic.lockaspectratio = msoTrue
      pic.Height = 150

      Else
        MsgBox ("No picture inserted")
       End If

End With

End Sub