Question

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

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

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

1 个答案: