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

Question

感谢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

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

经过测试，它基本上适合我。有任何问题：

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