VBA Excel 评论框 - 启用锁定纵横比

Question

我正在使用现有的 VBA 代码将图像插入 Excel 中的评论框中。我想锁定评论框的纵横比，还有select "Do not move or size with cell"

编辑 - 在@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' 属性。所以你的代码在那里产生了一个错误。但是，因为您已经声明了 "OnErrorResumeNext"，所以执行会忽略错误并从下一行开始。

所以，您没有发现任何问题，但是您尝试更改 LockAspectRatio 属性实际上并没有起作用，然后更改 Position 属性之后的位从不被执行。修复一行代码应该可以解决这两个问题。

VBA Excel 评论框 - 启用锁定纵横比

VBA Excel Comment Box - Enabling Lock Aspect Ratio

excel

vba

aspect-ratio