如何通过给定的单元名称将图片插入到单元格的注释中

感谢Macromarc这个问题已经解决了

我用我的代码的问题是它只是把图片放到一个单元格中，并且图片大小不正确。 当我过滤我的数据时，图片总是折叠到对方，看起来不太好。

以下是由Macromarc提供的正确的代码

Private Sub GrabImagePasteIntoCell() Const pictureNameColumn As String = "A" 'column where picture name is found Const picturePasteColumn As String = "J" 'column where picture is to be pasted Const pathForPicture As String = "M:\Users\Dan\Pictures\LabPics\" 'path of pictures Dim pictureFile As String Dim pictureName As String 'picture name Dim lastPictureRow As Long 'last row in use where picture names are Dim pictureRow As Long 'current picture row to be processed Dim picturePasteCell As Range pictureRow = 3 'starts from this row On Error GoTo Err_Handler Dim ws As Worksheet Set ws = ActiveSheet 'replace with better qualification lastPictureRow = ws.Cells(ws.Rows.Count, pictureNameColumn).End(xlUp).Row 'stop screen updates while macro is running Application.ScreenUpdating = False 'loop till last picture row Do While (pictureRow <= lastPictureRow) pictureName = ws.Cells(pictureRow, pictureNameColumn).Value2 If (pictureName <> vbNullString) Then 'check if pic is present pictureFile = pathForPicture & pictureName Set picturePasteCell = ws.Cells(pictureRow, picturePasteColumn) If (Dir(pictureFile & ".jpg") <> vbNullString) Then insertPictureToComment pictureFile & ".jpg", picturePasteCell, 41, 41 ElseIf (Dir(pictureFile & ".png") <> vbNullString) Then insertPictureToComment pictureFile & ".png", picturePasteCell, 100, 130 ElseIf (Dir(pictureFile & ".bmp") <> vbNullString) Then insertPictureToComment pictureFile & ".bmp", picturePasteCell, 100, 130 Else 'picture name was there, but no such picture picturePasteCell.Value2 = "No Picture Found" End If Else 'picture name cell was blank End If pictureRow = pictureRow + 1 Loop On Error GoTo 0 Exit_Sub: ws.Range("A10").Select Application.ScreenUpdating = True Exit Sub Err_Handler: MsgBox "Error encountered. " & Err.Description, vbCritical, "Error" GoTo Exit_Sub End Sub 

下面的函数处理将通用图像插入单元格的注释形状：

  Function insertPictureToComment(pictureFilePath As String, _ pictureRange As Range, _ commentHeight As Long, _ commentWidth As Long) Dim picComment As Comment If pictureRange.Comment Is Nothing Then Set picComment = pictureRange.AddComment Else Set picComment = pictureRange.Comment End If With picComment.Shape .Height = commentHeight .Width = commentWidth .LockAspectRatio = msoFalse .Fill.UserPicture pictureFilePath End With End Function 

Answer 1

我重写了一些其他代码，并重构了一个函数。

经过testing，它基本上为我工作。 有任何问题要问：

 Private Sub GrabImagePasteIntoCell() Const pictureNameColumn As String = "A" 'column where picture name is found Const picturePasteColumn As String = "J" 'column where picture is to be pasted Const pathForPicture As String = "M:\Users\Dan\Pictures\LabPics\" 'path of pictures Dim pictureFile As String Dim pictureName As String 'picture name Dim lastPictureRow As Long 'last row in use where picture names are Dim pictureRow As Long 'current picture row to be processed Dim picturePasteCell As Range pictureRow = 3 'starts from this row On Error GoTo Err_Handler Dim ws As Worksheet Set ws = ActiveSheet 'replace with better qualification lastPictureRow = ws.Cells(ws.Rows.Count, pictureNameColumn).End(xlUp).Row 'stop screen updates while macro is running Application.ScreenUpdating = False 'loop till last picture row Do While (pictureRow <= lastPictureRow) pictureName = ws.Cells(pictureRow, pictureNameColumn).Value2 If (pictureName <> vbNullString) Then 'check if pic is present pictureFile = pathForPicture & pictureName Set picturePasteCell = ws.Cells(pictureRow, picturePasteColumn) If (Dir(pictureFile & ".jpg") <> vbNullString) Then insertPictureToComment pictureFile & ".jpg", picturePasteCell, 41, 41 ElseIf (Dir(pictureFile & ".png") <> vbNullString) Then insertPictureToComment pictureFile & ".png", picturePasteCell, 100, 130 ElseIf (Dir(pictureFile & ".bmp") <> vbNullString) Then insertPictureToComment pictureFile & ".bmp", picturePasteCell, 100, 130 Else 'picture name was there, but no such picture picturePasteCell.Value2 = "No Picture Found" End If Else 'picture name cell was blank End If pictureRow = pictureRow + 1 Loop On Error GoTo 0 Exit_Sub: ws.Range("A10").Select Application.ScreenUpdating = True Exit Sub Err_Handler: MsgBox "Error encountered. " & Err.Description, vbCritical, "Error" GoTo Exit_Sub End Sub 

下面的函数处理将通用图像插入单元格的注释形状：

 Function insertPictureToComment(pictureFilePath As String, _ pictureRange As Range, _ commentHeight As Long, _ commentWidth As Long) Dim picComment As Comment If pictureRange.Comment Is Nothing Then Set picComment = pictureRange.AddComment Else Set picComment = pictureRange.Comment End If With picComment.Shape .Height = commentHeight .Width = commentWidth .LockAspectRatio = msoFalse .Fill.UserPicture pictureFilePath End With End Function