Вставить и изменить размер изображения в Excel, сохраняя соотношение сторон

Question

Я пытаюсь написать макрос VBA для Excel для встраивания и изменения размера изображения с сохранением соотношения сторон.Я бы хотел встраивать, а не создавать ссылки, чтобы файл Excel можно было использовать на разных компьютерах.

У меня есть 2 фрагмента кода.

1-й будет вставлять изображение (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»?

Может кто-нибудь предложить какое-нибудь руководство?

Большое спасибо.

Answer 1

Кажется, что теперь решено, и работает хорошо. Большое спасибо за помощь.

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

Answer 2

Если вы сделаете это в 2 шага, я думаю, что это будет работать, то есть вставьте изображение в исходном размере и установите 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