VBA应用

03 图形

一键插入多张图片到指定单元格的批注内

另一种嵌入图片的方法：在单元格批注中展示相关图片！

是的，批注不单单可以是文字，也可以是图片！

它的好处就是：鼠标放置单元格就显示、不放置就隐藏，非常优雅；不无缘故“撑大”单元格所在的行高和列宽！

结果如图所示：

关于代码：上个实例🔗一键插入多张图片到指定单元格位置中的大部分我们都可以复用，只不过在"插入位置"的几行代码，做相应的调整即可。"插入到单元格"调整为对"单元格创建图片批注"！

插入图片到单元格关键代码行:

调整为：创建图片批注关键代码行

它相当于把设置“批注样式”为图片的单一过程，加入了查找、判断和循环。

单个设置“批注样式”为图片的过程：

1、插入批注，设置显示状态为"显示批注";
2、选中批注，右键"设置批注格式"（注意是"批注格式"，而不是"批注文本"格式）;
3、选择"颜色与线条"—"颜色"—"图片"，选择需要插入的图片即可；

该实例只在“一键插入多张图片到指定单元格位置”基础上做了小的调整，大量的基础知识都是一样的，都包含了：插入位置的选择、图片的选择等等。我们就单对关键实现过程的细节详细描述下，其他可参考🔗一键插入多张图片到指定单元格位置

运行视频：

源码下载：

描述：

一键批量插入多张图片到表格批注，要求：指定插入在单元格批注、图片和单元格内容匹配、允许调整图片的宽和高度，插入后默认批注是"隐藏"状态。

样本示例：

需求分析：

1、在"车型"所在列的单元格，插入对应的产品图片到批注。

VBA实现过程：

1.就是图片的插入工作：
2.一个for循环，遍历选择的图片，获取图片名称；
3.嵌套一个Do Loop...While循环，查找所有于图片名字匹配的单元格值；
4.主要实现过程：

①.AddComment 方法，添加批注；
②.Comment.Visible= True 设置批注为可见
③.Comment.Shape.Fill.UserPicturePic(i) 创建图片批注
④.Comment.Shape.Height\.Comment.Shape.Width设置图片的宽和高度
⑤.Comment.TextText:=""批注的文本内容要为空，否则会显示默认文本
⑥.Comment.Visible= False 最后设置为不可见"隐藏"模式。

5、完成！

示例代码

复制成功!


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

VBA常用小代码