批量插入图片到单元格批注

Sub 批量插入批注图片()
    '-----------------------------------------------------------------------
    '自定义数据类型
    Dim ImgFileFormat, FirstAddress As String
    Dim Pic As Variant, Pic_name As String, Sizes As String
    Dim Choose_rng, rng As Range
    Dim i As Integer
    Dim C As Range
    
    '选择需要插入区域
    On Error Resume Next
    Set Choose_rng = Application.InputBox("选择需要插入的单元格或单元格区域", Type:=8)
    If Err.Number > 0 Then MsgBox "未选择内容": Exit Sub
    If WorksheetFunction.CountA(Choose_rng) = 0 Then MsgBox "选择单元格区域为空": Exit Sub
    On Error GoTo 0
    
    '选择需要插入的图片及自定义图片的高度与宽度
    ImgFileFormat = "Image files (*.bmp;*.gif;*.tif;*.jpg;*.jpeg)," & "*.bmp;*.gif;*.tif;*.jpg;*.jpeg" '指定图片格式
    Pic = Application.GetOpenFilename(ImgFileFormat, , "选择多张图片", , True) '打开一个图片选择对话框
    If VBA.TypeName(Pic) = "Boolean" Then
        MsgBox "没有选择文件": Exit Sub
    End If

Star:
    Sizes = Application.InputBox("请指定图片的高度与宽度，中间用半角逗号隔开" & Chr(10) & "例如“30,260”或者“80,100”", "指定批注大小", "100,120", , , , , 2)
    If InStr(Replace(Sizes, ", ", ","), ",") = 0 Then GoTo Star '如果没有输入","则返回重新输入
    
   Application.ScreenUpdating = False
   Application.DisplayAlerts = False
    
    For i = 1 To UBound(Pic)
        '获取图片名字
        Pic_name = StrReverse(Mid(StrReverse(Pic(i)), WorksheetFunction.Find(".", StrReverse(Pic(i))) + 1, WorksheetFunction.Find("\", StrReverse(Pic(i))) - 1 - WorksheetFunction.Find(".", StrReverse(Pic(i)))))
        
        '添加图片批注
        With Choose_rng
            Set C = .Find(Pic_name, LookIn:=xlValues)
            If Not C Is Nothing Then
                FirstAddress = C.Address
                Do
                    C.ClearComments '清除原有批注
                    With C  '引用当前单元格
                        .AddComment '添加批注
                        .Comment.Visible = True
                        .Comment.Shape.Fill.UserPicture Pic(i) '设置普通填充
                        .Comment.Shape.Select True  '选择批注
                        .Comment.Shape.Height = Split(Replace(Sizes, ", ", ","), ",")(0) '自定义高度
                        .Comment.Shape.Width = Split(Replace(Sizes, ", ", ","), ",")(1)  '自定义宽度
                        .Comment.Text Text:="" '用空格作为批注内容
                        .Comment.Visible = False '不可见
                    End With
                    Set C = .FindNext(C)
                Loop While Not C Is Nothing And C.Address <> FirstAddress
            End If
        End With
    Next i
    
   Application.ScreenUpdating = True
   Application.DisplayAlerts = True
   MsgBox "插入批注图片完成"
End Sub
1：多图片的批量识别插入
2：自定义图片宽高
3：产品宣导图表
源码视频演示
批量插入图片到单元格批注

目录
