Окно комментария VBA Excel - включение коэффициента блокировки

Question

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

РЕДАКТИРОВАТЬ - Опубликовал код с помощью @Ryan B. - Отлично работает!

Sub add_content_image()

    'NOTE: THE RESIZER ONLY WORKS FOR JPG IMAGES
    Dim myFile As FileDialog, ImgFile, myImg As Variant
    Dim ZoomF As Variant                         'string
    On Error Resume Next

    Set myFile = Application.FileDialog(msoFileDialogOpen)
    With myFile
        .Title = "Choose File"
        .AllowMultiSelect = False
        .Filters.Add Description:="Images", Extensions:="*.jpg,*.Jpg,*.gif,*.png,*.tif,*.bmp", Position:=1
        If .Show <> -1 Then
            MsgBox "No image selected", vbCritical
            Exit Sub
        End If
    End With

    ImgFile = myFile.SelectedItems(1)
    If ImgFile = False Then Exit Sub
    Application.ScreenUpdating = False
    ZoomF = InputBox(Prompt:="Your selected file path:" & _
                              vbNewLine & ImgFile & _
                              vbNewLine & "" & _
                              vbNewLine & "Input zoom % factor to apply to picture?" & _
                              vbNewLine & "(Original picture size equals 100) ." & _
                              vbNewLine & "Input a number greater than zero!", Title:="Picture Scaling Percentage Factor", Default:=100)

    If Not IsNumeric(ZoomF) Or ZoomF = 0 Or ZoomF = "" Then
        MsgBox "You must enter a valid numeric value. Entered value must be a number greater than zero." & _
               vbNewLine & "Macro will terminate.", vbCritical
        Exit Sub
    End If
    With ActiveCell
        .ClearComments
        .AddComment
        .Interior.ColorIndex = 19
        .Value = "Hover for Image"
    End With

    Set myImg = LoadPicture(ImgFile)
    With ActiveCell.Comment
        .Shape.Fill.UserPicture ImgFile
        .Shape.Width = myImg.Width * ZoomF / 2645.9
        .Shape.Height = myImg.Height * ZoomF / 2645.9
        .Shape.LockAspectRatio = msoTrue
        .Shape.Placement = 3                     'do not move or size with cells

    End With
    Application.ScreenUpdating = True
    Set myFile = Nothing: Set myImg = Nothing
End Sub

Answer 1

Учитывая ваш блок кода:

With ActiveCell.Comment
    .Shape.Fill.UserPicture ImgFile
    .Shape.Width = myImg.Width * ZoomF / 2645.9
    .Shape.Height = myImg.Height * ZoomF / 2645.9
    .ShapeRange.LockAspectRatio = msoTrue 'this does not seem to work
    .Shape.Placement = 2 'move but do not size with cells

End With

Я полагаю, вы хотите изменить эту строку:

.ShapeRange.LockAspectRatio = msoTrue

на эту:

.Shape.LockAspectRatio = msoTrue

Нет'свойство' ShapeRange 'для объекта Comment.Таким образом, ваш код генерирует ошибку там.Но поскольку вы объявили «OnErrorResumeNext», выполнение игнорирует ошибку и начинается со следующей строки.

Итак, вы не видите никаких проблем, но ваша попытка изменить свойство LockAspectRatio на самом деле не работает, а затем бит, который следует после изменения свойства Position, никогда не выполняется.Исправление одной строки кода должно решить обе проблемы.