Question

我发现此代码将图像插入excel 2013，但图像比他们进入的单元格大。我认为将图像作为注释加载的最佳选择。

有人可以在下面修改此VBA，将其添加为评论吗？

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

我相信以下链接有您要找的内容

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

如果您希望图像与目标单元格高度大小匹配，请使用：

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

如果要匹配单元格和高度使用：

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

我更新了上面的代码，并且我也从“＃B; B＆＃34; （第2栏）。我在单击鼠标时运行我的宏：

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

这将在您单击的单元格上快速添加图片作为注释。它还将它调整为我喜欢的项目。

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

这可用于批处理操作一次性添加一堆图像作为评论

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

希望这对找到批处理作业的人有所帮助。

添加图像作为评论VBA

5 个答案: