add image as comment VBA

Question

I found this code to insert images into excel 2013 but the images are large than the cells they're going into. I think the best option it to load the images as comments.

Can someone modify this VBA below to add this as a comment?

Sub URLPictureInsert()
Dim cell, shp As Shape, target As Range
    Set rng = ActiveSheet.Range("R2:R5") ' range with URLs
    For Each cell In rng
       filenam = cell
       ActiveSheet.Pictures.Insert(filenam).Select

  Set shp = Selection.ShapeRange.Item(1)
   With shp
      .LockAspectRatio = msoTrue
      .Width = 50
      .Height = 50
      .Cut
   End With
   Cells(cell.Row, cell.Column + 5).PasteSpecial

Next

End Sub

Answer 1

I believe The following link has what you are looking for

http://en.kioskea.net/faq/8619-excel-a-macro-to-automatically-insert-image-in-a-comment-box

Sub Img_in_Commentbox()  
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:="*.jpg", Position:=1  
         .Title = "Choose image"  

         If .Show = -1 Then TheFile = .SelectedItems(1) Else TheFile = 0  
    End With  
'No file selected  
If TheFile = 0 Then  
MsgBox ("No image selected")  
Exit Sub  
End If  
Range("A1").AddComment  
    Range("A1").Comment.Visible = True  
[A1].Comment.Shape.Fill.UserPicture TheFile  
End Sub

Answer 2

If you want your images to match your destination cell height size use:

With shp
    .LockAspectRatio = msoTrue
    '.Width = Cells(cell.Row, cell.Column + 5).Width 'Uncomment this  line and comment out .Height line to match cell width
    .Height = Cells(cell.Row, cell.Column + 5).Height 
    .Cut
End With

If you want to match both cell with and height use:

With shp
    .LockAspectRatio = msoFalse
    .Width = Cells(cell.Row, cell.Column + 5).Width
    .Height = Cells(cell.Row, cell.Column + 5).Height
    .Cut
End With

Answer 3

I updated code above and also I take path to the image from Column "B" (Column 2). I raun my macro on cell click:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim listWS As Worksheet
Dim targetCol, targetRow As Long
Dim TheFile As String

Set listWS = Application.ThisWorkbook.Sheets("Catalogue")
    If Target.Column = 2 Then
        targetCol = Target.Column
        targetRow = Target.Row
        TheFile = listWS.Cells(targetRow, targetCol).Value
        With listWS.Range(listWS.Cells(targetRow, 4), listWS.Cells(targetRow, 4))
            .AddComment
            .Comment.Visible = True
            .Comment.Shape.Fill.UserPicture TheFile
        End With
    End If
End Sub

Answer 4

This will add a picture as a comment quickly on the cell you are clicked on. It also resizes it to what I liked for the project I was doing.

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:="*.png", Position:=1
     .Title = "Choose image"

     If .Show = -1 Then TheFile = .SelectedItems(1) Else TheFile = 0
End With
'No file selected
If TheFile = 0 Then
MsgBox ("No image selected")
Exit Sub
End If
Selection.AddComment
Selection.Comment.Visible = True
Selection.Comment.Shape.Fill.UserPicture TheFile
Selection.Comment.Shape.Select True
Selection.ShapeRange.ScaleWidth 2.6, msoFalse, msoScaleFromTopLeft
Selection.ShapeRange.ScaleHeight 2.8, msoFalse, msoScaleFromTopLeft
ActiveCell.Comment.Visible = False

Answer 5

Paste the below code in ThisWorkbook and then close it and open it. Whenever you paste the screenshot in Cell it will automatically resize

Option Explicit

#If VBA7 Then
Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
Private Declare PtrSafe Function EnumClipboardFormats Lib "user32" (ByVal wFormat As Long) As Long
Private Declare PtrSafe Function GetClipboardFormatName Lib "user32" Alias "GetClipboardFormatNameA" (ByVal wFormat As Long, ByVal lpString As String, ByVal nMaxCount As Long) As Long
#Else
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function EnumClipboardFormats Lib "user32" (ByVal wFormat As Long) As Long
Private Declare Function GetClipboardFormatName Lib "user32" Alias "GetClipboardFormatNameA" (ByVal wFormat As Long, ByVal lpString As String, ByVal nMaxCount As Long) As Long
#End If

Private WithEvents CmndBras As CommandBars


Private Sub Workbook_Open()
Set CmndBras = Application.CommandBars
End Sub
Private Sub Workbook_SheetSelectionChange(ByVal sh As Object, ByVal Target As Range)
Set CmndBras = Application.CommandBars
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Set CmndBras = Nothing
End Sub


Private Sub CmndBras_OnUpdate()
Dim oShp As Shape

On Error Resume Next
If TypeName(Selection) <> "Range" Then
    If ScreenShotInClipBoard Then
        Set oShp = Selection.Parent.Shapes(Selection.Name)
        With oShp
        If .AlternativeText <> "Tagged" Then
            If .Type = msoPicture Then
                If Err.Number = 0 Then
                    .AlternativeText = "Tagged"
                    .Visible = False
                    .LockAspectRatio = msoFalse
                    .Top = ActiveWindow.RangeSelection.Top
                    .Left = ActiveWindow.RangeSelection.Left
                    .Width = ActiveWindow.RangeSelection.Width
                    .Height = ActiveWindow.RangeSelection.Height
                    ActiveWindow.RangeSelection.Activate
                    .Visible = True
                End If
            End If
        End If
        End With
    End If
End If
End Sub


Private Function ScreenShotInClipBoard() As Boolean
Dim sClipboardFormatName As String, sBuffer As String
Dim CF_Format As Long, i As Long
Dim bDtataInClipBoard As Boolean

If OpenClipboard(0) Then
    CF_Format = EnumClipboardFormats(0&)
    Do While CF_Format <> 0
        sClipboardFormatName = String(255, vbNullChar)
        i = GetClipboardFormatName(CF_Format, sClipboardFormatName, 255)
        sBuffer = sBuffer & Left(sClipboardFormatName, i)
       bDtataInClipBoard = True
         CF_Format = EnumClipboardFormats(CF_Format)
    Loop
    CloseClipboard
 End If
 ScreenShotInClipBoard = bDtataInClipBoard And Len(sBuffer) = 0
End Function

Answer 6

this can be used for batch operations add a bunch of images as comment in one go

Sub Fill_Selection_with_Image_As_Comments()

Dim n As Integer
Dim i As Integer
Dim cmt As Comment
Dim rng As Range
Dim Workrng As Range
Dim strPic As String

On Error Resume Next

Set Workrng = Application.Selection
Set Workrng = Application.InputBox(Prompt:="Please select a range!", Title:="Range to target", Type:=8)
i = 1

With Application.FileDialog(msoFileDialogFilePicker)
    .AllowMultiSelect = True
    .Title = "Select Images"
    .ButtonName = "Select"
    If .Show <> -1 Then
        Exit Sub
    End If

    n = .SelectedItems.Count

    For Each rng In Workrng
        rng.AddComment
        Set cmt = rng.Comment
       If Not cmt Is Nothing Then
        strPic = .SelectedItems(i)
            With cmt.Shape
                .Height = 400
                .Width = 500
                .Fill.UserPicture strPic

            End With
       End If
        i = i + 1
        If i = n + 1 Then
            Exit Sub
        End If
   Next rng
End With

MsgBox "Done"
End Sub

Hope this helps some one who is finding a batch operations work.