在Excel中嵌入图像并调整其大小,以保持宽高比

时间:2018-09-11 11:05:51

标签: vba image resize embed aspect-ratio

我正在尝试为Excel写一个VBA宏,以嵌入和调整图像尺寸以保持纵横比。我想嵌入而不是链接,以便Excel文件可以在计算机之间共享。

我有2条代码。

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

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

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

End Sub

2nd将链接图像,调整图像位置并更改高度(保持纵横比)。此选项不会嵌入图像。

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”吗?

有人可以提供一些指导吗?

非常感谢。

2 个答案:

答案 0 :(得分:0)

如果分两步进行操作,我认为它将起作用,即以原始大小插入图像并设置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

答案 1 :(得分:0)

似乎现在需要解决,并且效果很好。非常感谢您的帮助。

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