add image as comment VBA

问题:

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

回答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

回答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

回答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

回答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