VBA应用

03 图形

一键插入多张图片到指定单元格位置(设置图片宽高度)

用Excel做产品库，很多行业的伙伴并不会陌生。

比如：某列是产品序号、之后是它的相关介绍(包含但不限于FABE话术)。在鞋服零售行业时，简直是背它背到吐！每年新款上市前的订货会，大量的培训等基础工作要做。

Excel整理产品库下发，需要把图片内容对应到每个款式、贴到产品之后(有些公司可能直接就PPT上了，但是对于品牌方来说，不同系列、上市时间、材料属性且SKU多多的产品，PPT远不如Excel更为直观)。

这就牵扯到产品和图片对应和逐一插入、调整大小适应单元格的问题！已知产品是按规则编码命名的、图片也是相同的命名，在摄影师批量提交图片后，如何快速且优雅的把它们插入到对应的产品库表格中？

如同了解过分享过的基础课程和一些VBA实例，这时会想到：超控图片对象、用图片名称查找、和Range单元格内容匹配一致后、.Insert插入图片到指定单元格的过程！

对于图形对象，我们了解的不多。在基础篇中关于对象的介绍，每个章节开篇的“对象的层级结构图”中，知道它们是和Range单元格对象处于一个层级。既然是对象，也会有它的属性和方法，用本章的实例，来看下图形对象的一些常规操作。

其它的实现细节，什么方法可以识别图片？名字如何获取和匹配？循环的使用等等，这些会在示例代码逐行说明，它并不复杂，了解过基础知识的一眼明了。

运行视频：

源码下载：

描述：

一键批量插入多张图片到表格中，要求：指定插入在单元格位置的右侧列、图片和单元格内容匹配、允许调整图片的宽和高度，单元格的行高和列宽和图片吻合。

样本示例：

需求分析：

1、选择"产品名称"(指定插入的位置)；
2、选择需要插入的产品图片；
3、指定图片的宽和高；
4、在"产品名称"所在列的右侧列，插入对应的产品图片且单元格的行高和列宽自动适应图片。

VBA实现过程：

1.Application.InputBox方法，让用户自定义选择"产品序号"所在单元格区域；
2.Application.GetOpenFilename方法，打开对话框，FileFilter参数，指定文件筛选条件，这里必须是所有的、常见图形文件的后缀有：(*.bmp;*.gif;*.tif;*.jpg;*.jpeg;*.png)；
3.获取图形的名字很有意思，正常我们通过"打开对话框"批量选择图片后，里面的单个元素是该图片的完整路径，比如"C:\文件\图片\Pic.jpg"，我们该如何获取"Pic"呢？我们知道它的前面必定是"\"后面必定是"."，但是前面有几个"\"就不清楚了，它取决于路径，但是如果把路径这个字符串反过来，它必定是第一个"\"，我们用了两个StrReverse内置的反转函数，先把字符串反转过来，mid截取后，再反转回来，就得到了"图形名字Pic"；
4.Application.InputBox方法，可以让用户选择单元格，也可以让他们指定图片的宽和高；
5.接着就是图片的插入工作：

①:一个for循环，遍历选择的图片，获取图片名称；
②嵌套一个Do Loop...While循环，查找所有与图片名字匹配的单元格值；
③Pictures.Insert方法，图片插入；
④.Left、.Top，图形的属性值设置，决定图形的左上角在表格中的左边、顶部位置；
⑤.Height、.Width，图形的属性值设置，决定这图形的高度和宽度；
⑥.RowHeight、.ColumnWidth，单元格的属性值设置，单元格的高度和宽度。

5、完成！

示例代码

复制成功!


Sub 批量插入图片到工作表()
    '-----------------------------------------------------------------------
    '自定义数据类型
    Dim ImgFileFormat, FirstAddress As String
    Dim Pic As Variant, Pic_name As String, Sizes As String, Choose_sht_name As String
    Dim Choose_rng, rng As Range
    Dim i As Integer
    Dim C As Range
    Dim Shp As Shape  '声明图形对象变量


    '选择需要插入区域
    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
    Choose_sht_name = Choose_rng.Parent.Name
    On Error GoTo 0

    '选择需要插入的图片及自定义图片的高度与宽度
    ImgFileFormat = "Image files (*.bmp;*.gif;*.tif;*.jpg;*.jpeg;*.png)," & "*.bmp;*.gif;*.tif;*.jpg;*.jpeg;*.png" '指定图片格式
    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
                    Sheets(Choose_sht_name).Activate
                    Sheets(Choose_sht_name).Pictures.Insert(Pic(i)).Select  '插入图片

                    With Selection
                        .Left = C.Offset(0, 1).Left '使图片的左边距等于其左上单元格的左边距
                        .Top = C.Offset(0, 1).Top    '使图片的上边距等于其左上单元格的上边距
                        .Height = Split(Replace(Sizes, ", ", ","), ",")(1) '调整图片高度
                        .Width = Split(Replace(Sizes, ", ", ","), ",")(0)  '调整图片宽

                        C.Offset(0, 1).RowHeight = .Height '调整行宽度
                        C.Offset(0, 1).ColumnWidth = .Width / 5.5 '调整列宽度,模糊调整

                    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常用小代码