Excel VBA Macro: создать поле для комментариев и вставить картинку в полном размере

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