在工作过程中需要向Excel单元格中批注中插入图片,VBA代码记录如下：

    1. 'insert photo
    2. Sub pictopz()
    3. Dim cell As Range, fd, t, w As Byte, h As Byte, fso, pics
    4. Set fso = CreateObject("scripting.filesystemobject")
    5. Selection.ClearComments
    6. If Selection(1) = "" Then MsgBox "不能选择空白区。", 64, "提示": Exit Sub
    7. On Error GoTo err
    8. Set fd = Application.FileDialog(msoFileDialogFolderPicker)    '允许用户选择一个文件夹
    9. If fd.Show = -1 Then
    10. t = fd.SelectedItems(1)    '选择之后就记录这个文件夹名称
    11. Else
    12. Exit Sub    '否则就退出程序
    13. End If
    14. w = Application.InputBox("您希望插入的图片显示多宽？" & Chr(10) & "Excel默认宽度为3.39，你可以输入1-15之间的数据。" & Chr(10) & "小于1时当做1计算。", "确认宽度", 3.39, , , , , 2)
    15. h = Application.InputBox("您希望插入的图片显示多高？" & Chr(10) & "Excel默认高度为2.09，你可以输入1-15之间的数据。" & Chr(10) & "小于1时当做1计算。", "确认高度", 2.09, , , , , 2)
    16. If w < 1 Or h < 1 Then w = 3.39: h = 2.09
    17. If w > 15 Or h > 15 Then MsgBox "原则上你的图片可以显示这么大，" & Chr(10) & "不过有必要吗？请重新输入1-15之间的数", 64, "提示": Exit Sub
    18. For Each cell In Selection
    19. pics = t & "\" & cell.Text & ".jpg"
    20. If fso.fileexists(pics) Then
    21. With cell.AddComment
    22. .Visible = True
    23. .Text Text:=""
    24. .Shape.Select True
    25. With Selection.ShapeRange
    26. .Fill.UserPicture pics
    27. .ScaleWidth w / 3, msoFalse, msoScaleFromTopLeft
    28. .ScaleHeight h / 2.09, msoFalse, msoScaleFromTopLeft
    29. End With
    30. cell.Offset(1, 0).Select
    31. .Visible = False
    32. End With
    33. End If
    34. Next
    35. Exit Sub
    36. err:
    37. ActiveCell.ClearComments
    38. MsgBox "未找到同名的JPG图片！", 64, "提示"
    39. End Sub

    使用方法：
    选取EXCEL中需要插入图片的货品编码,执行插入图片宏代码，将会让你打开放图片的文件夹，选中文件夹即可。
    注意事项：需要插入的图片需要用对应的货品编码命名，当前图片格式选用jpg.
    insert-photo-comments.gif