[SOLVED] Excel VBA Macro: Create comment box and insert picture in full size

Excel VBA Macro: Create comment box and insert picture in full size

For decoration of a measurement table in Excel I need to add many pictures assigned to rows. Without resizing the row the only option is to add each picture into a comment box that is shown on mouse-over. Another important requirement is to show the pictures in full size. The default comment box size is too small. It is possible to add comment boxes with pictured background by hand but involves many clicks per picture which is very time consuming. What could a macro look like that gives you a right-click option on a cell to display a FileChooser window and inserts the selected picture into a newly created comment box in full size?

Solution

I finally made this macro, copied from parts of different tutorials. Hope this helps others too. With this you can right-click a cell, choose a picture and it will be inserted as comment in full scale.

Add this to worksheet to add macro to right-click menu:

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 method to add scaled picture from path to cell

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