EXCEL批量插入批注图片，如果没有相对应的图片就不插入对应表格批注的办法!

heyihan_23

Sub 批量插入同名照片到批注()
Dim a
a = MsgBox("【特别注意】：选中图片文件夹，保证图片文件名与插入批注表格的内容一样！", vbOKCancel, "【蓝迪资料员HM】")
Dim cell As Range, fd, t
Dim PicPath As String
Dim ErrCell As String
Selection.ClearComments
On Error Resume Next
Set fd = Application.FileDialog(msoFileDialogFolderPicker) '允许用户选择一个文件夹
If fd.Show = -1 Then
t = fd.SelectedItems(1) '选择之后就记录这个文件夹名称
End If
For Each cell In Selection
With cell.AddComment
.Visible = True
.Text Text:=""
.Shape.Select True
Selection.ShapeRange.Fill.UserPicture t & "\" & cell.Text & ".jpg"
.Shape.Width = 150 'Add these 2 statement
.Shape.Height = 150
Selection.ShapeRange.Fill.UserPicture t & "\" & cell.Text & ".png"
.Shape.Width = 150 'Add these 2 statement
.Shape.Height = 150
cell.Offset(1, 0).Select
.Visible = False
End With
Next
End Sub[url=]收起[/url]
在这个区域批量插入对应的图片的时候，我现在只弄了三张对应图片，但是现在选中的区域虽然把对应的图片插入上了，但是没有图片的表格也插入了批注，只是没有图片，我希望这样的没有图片的表格就不插入批注的方法！

heyihan_23

请高手帮忙看看要怎么实现啊，以后还有许多问题要请大家帮助啊，拜托了！

z13437807298

Sub 查看图片()

    'ExcelHome VBA编程学习与实践 看见星光
    Dim Arr, i&, k&, n&, pd&
    Dim PicName$, PicPath$, FdPath$
    Dim Rng As Range, Cll As Range
    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")
    '用数组变量记录五种文件格式
    Application.ScreenUpdating = False
    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 = 100 '图形的高度，可以根据需要自己调整
                        .Shape.Width = 55 '图形的宽度，可以根据需要自己调整
                        .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

646804566

z13437807298 发表于 2018-9-17 11:26
Sub 查看图片()

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

哦，自己没看到，其实是有这个功能的