VBA小代码：批量在批注中插入图片

nnsea

Sub CommentPic()

    'ExcelHome VBA编程学习与实践 看见星光

    Dim Arr, i&, k&, n&, pd&

    Dim PicName$, PicPath$, FdPath$

    Dim Rng As Range, Cll As Range

    Application.ScreenUpdating = False

    On Error Resume Next

    '

    '用户选择图片所在的文件夹

    With Application.FileDialog(msoFileDialogFolderPicker)

        .AllowMultiSelect = False '不允许多选

       If .Show Then FdPath = .SelectedItems(1) Else: Exit Sub

    End With

    If Right(FdPath, 1) <> "\" Then FdPath = FdPath & "\"

    '

    Set Rng = Application.InputBox("请选择需要插入图片到批注中的单元格区域", Type:=8)

    '用户选择需要插入图片到批注中的单元格或区域

    If Rng.Count = 0 Then Exit Sub

    Set Rng = Intersect(Rng.Parent.UsedRange, Rng)

    'intersect语句避免用户选择整列单元格，造成无谓运算的情况

    Arr = Array(".jpg", ".jpeg", ".bmp", ".png", ".gif")

    '用数组变量记录五种文件格式

    '

    For Each Cll In Rng

    '遍历选择区域的每一个单元格

        Cll.Comment.Delete '删除旧的批注

        PicName = Cll.Text '图片名称

        If Len(PicName) Then '如果单元格存在值

            PicPath = FdPath & PicName '图片路径

            pd = 0 'pd变量标记是否找到相关图片

            For i = 0 To UBound(Arr)

            '由于不确定用户的图片格式，因此遍历图片格式

                If Len(Dir(PicPath & Arr(i))) Then

                '如果存在相关文件

                    Cll.AddComment '增加批注

                    With Cll.Comment

                        .Visible = True '批注可见

                        .Text Text:=""

                        .Shape.Select True '选中批注图形

                        Selection.ShapeRange.Fill.UserPicture PicPath & Arr(i)

                        '插入图片到批注中

                        .Shape.Height = 150 '图形的高度，可以根据需要自己调整

                        .Shape.Width = 150 '图形的宽度，可以根据需要自己调整

                        .Visible = False '取消显示

                    End With

                    pd = 1 '标记找到结果

                    n = n + 1 '累加找到结果的个数

                    Exit For '找到结果后就可以退出文件格式循环

                End If

            Next

            If pd = 0 Then k = k + 1 '如果没找到图片累加个数

        End If

    Next

    MsgBox "共处理成功" & n & "个图片，另有" & k & "个非空单元格未找到对应的图片。"

    Application.ScreenUpdating = True

End Sub