Как установить соотношение сторон изображения?

Question

Sub ExampleUsage() 
    Dim myPicture As String, myRange As Range 
    myPicture = Application.GetOpenFilename _ 
     ("Pictures (*.gif; *.jpg; *.bmp; *.tif),*.gif; *.jpg; *.bmp; *.tif", _ 
     , "Select Picture to Import") 

    Set myRange = Selection 
    InsertAndSizePic myRange, myPicture 
End Sub 

Sub InsertAndSizePic(Target As Range, PicPath As String) 
    Dim p As Object 
    Application.ScreenUpdating = False 
    Set p = ActiveSheet.Pictures.Insert(PicPath) 

    If Target.Cells.Count = 1 Then Set Target = Target.MergeArea 
    With Target 
     p.Top = .Top 
     p.Left = .Left 
     p.Width = .Width 
     p.Height = .Height 
    End With 
End Sub 

Это мой код для Microsoft Excel. Я хочу разблокировать соотношение сторон, чтобы я мог заполнить всю объединенную ячейку. Заранее спасибо.

Answer 1

Вот как вы установите Соотношение сторон.
Это НедвижимостьФорма Объект. p от Picture Object Type. Вы можете использовать это имя для доступа к нему через Shapes, который имеет Aspect Ratio свойство:

Sub InsertAndSizePic(Target As Range, PicPath As String) 
    Dim p As Object 
    Application.ScreenUpdating = False 
    Dim sh As Worksheet: Set sh = ActiveSheet 
    Set p = sh.Pictures.Insert(PicPath) 
    sh.Shapes(p.Name).LockAspectRatio = False 

    If Target.Cells.Count = 1 Then Set Target = Target.MergeArea 
    With Target 
     p.Top = .Top 
     p.Left = .Left 
     p.Width = .Width 
     p.Height = .Height 
    End With 
    Application.ScreenUpdating = True 
End Sub 

Я объявил и установить переменную для Worksheet Object просто иметь Intellisense удар, чтобы получить аргументы.

Другой способ - использовать Shape Object AddPicture Method, как показано ниже.

Sub InsertAndSizePic(Target As Range, PicPath As String) 
    Dim s As Shape 
    Application.ScreenUpdating = False 
    Dim sh As Worksheet: Set sh = ActiveSheet 

    If Target.Cells.Count = 1 Then Set Target = Target.MergeArea 
    With Target 
     Set s = sh.Shapes.AddPicture(PicPath, True, True, .Left, .Top, .Width, .Height) 
    End With 
    Application.ScreenUpdating = True 
End Sub 

Этот код также выполняет то, что делает первый код. НТН.