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

Comment对象上没有'ShapeRange'属性。因此，您的代码在那里产生了错误。但是，由于您已声明“ OnErrorResumeNext”，因此执行将忽略该错误并从下一行开始。

因此，您看不到任何问题，但是您尝试更改LockAspectRatio属性实际上是行不通的，因此更改Position属性之后的代码永远不会执行。修复一行代码应该可以解决这两个问题。

VBA Excel注释框-启用锁定宽高比

1 个答案: