Excel VBA宏:创建注释框并以全尺寸插入图片

Question

为了在Excel中装饰测量表，我需要添加许多分配给行的图片。在不调整行大小的情况下，唯一的选择是将每张图片添加到鼠标悬停时显示的注释框中。另一个重要要求是以全尺寸显示图片。默认注释框大小太小。可以手动添加带有图片背景的评论框，但每张图片需要多次点击，这非常耗时。宏看起来像什么，让您在单元格上右键单击选项以显示文件选择器窗口并将所选图片以全尺寸插入新创建的注释框中？

Answer 1

我终于制作了这个宏，从不同教程的部分复制而来。希望这也对其他人有所帮助。有了这个，您可以右键单击一个单元格，选择一张图片，它将作为全尺寸的注释插入。

将此添加到工作表以将宏添加到右键单击菜单：

Private Sub Workbook_Deactivate()
    On Error Resume Next
        With Application
            .CommandBars("Cell").Controls("CommentPic").Delete
        End With
    On Error GoTo 0
End Sub
Private Sub Workbook_SheetBeforeRightClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
    Dim cmdBtn As CommandBarButton
        On Error Resume Next
            With Application
                .CommandBars("Cell").Controls("CommentPic").Delete
            Set cmdBtn = .CommandBars("Cell").Controls.Add(Temporary:=True)
            End With
            With cmdBtn
                .Caption = "CommentPic"
                .Style = msoButtonCaption
                .OnAction = "CommentPic"
            End With
        On Error GoTo 0
End Sub

将缩放图片从路径添加到单元格的子方法

Sub CommentPic()
    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = False          'Only one file
        .InitialFileName = CurDir         'directory to open the window
        .Filters.Clear                    'Cancel the filter
        .Filters.Add Description:="Images", Extensions:="*.*", Position:=1
        .Title = "Choose image"
            If .Show = -1 Then TheFile = .SelectedItems(1) Else TheFile = 0
    End With
Dim myfile As String
myfile = TheFile
With Selection
    '--- delete any existing comment just for testing
    If Not Selection.Comment Is Nothing Then
        Selection.Comment.Delete
    End If
    InsertCommentWithImage Selection, myfile, 1#
    Selection.Value = "IMG"  
End With
End Sub
Sub InsertCommentWithImage(imgCell As Range, _
                       imgPath As String, _
                       imgScale As Double)
    '--- first check if the image file exists in the
    '    specified path
    If Dir(imgPath) <> vbNullString Then
        If imgCell.Comment Is Nothing Then
            imgCell.AddComment
        End If
    '--- establish a Windows Image Acquisition Automation object
    '    to get the image's dimensions
    Dim imageObj As Object
    Set imageObj = CreateObject("WIA.ImageFile")
    imageObj.LoadFile (imgPath)
    Dim width As Long
    Dim height As Long
    width = imageObj.width
    height = imageObj.height
    '--- simple scaling that keeps the image's
    '    original aspect ratio
    With imgCell.Comment
        .Shape.Fill.UserPicture imgPath
        .Shape.height = height * imgScale
        .Shape.width = width * imgScale
        End With
    End If
End Sub