实用VBA：10.用VBA向Excel文件中自动插入图片

1.需求场景

上次介绍了“使用Excel批量套模板，一键输出多个工作表”的内容，可以通过VBA对大批量的数据进行模板化输出，类似于Word中的邮件合并的效果，在Excel中使用更灵活，可以自定义输出范围，便于修改调整模板格式。实际工作中，套模板输出的时候常常需要插入图片，例如人员简历中的证件照，工作日志中的现场照片等。如果原始照片大小不一，还需要按比例进行缩放。同样可以使用VBA进行批量处理，而且可以和数据一并处理。

例如数据还是上次的数据，只是模板中多了照片的位置。

1. 2.解决思路

按照手工插入图片的步骤，需要插入图片到表格——对齐边缘到单元格——缩放图片到表格大小。用VBA处理时，可以考虑事先将图片存储在统一目录下，文件名与基础数据建立关联，例如证件照以人员姓名命名或以人员编号命名，工作现场照片等以基础数据表中具有唯一性的字段命名，如果一个表中要插入多个照片（即每行数据对应多个图片），可以加上规律的后缀-1、-2……等。通过拼接出文件完整路径的方式进行调用。

调用工作表Shapes对象的AddPicture()方法，再和调整图片位置、大小属性的操作封装到一起，构建为自定义的插入图片的方法。

3.VBA实现

只需要在上次的代码基础上进行少量的改进即可实现。

'定义工作簿变量

Dim wb As Workbook

'定义工作表变量

Dim ws, sh As Worksheet

'定义临时存储基本信息数据各字段的变量

Dim pName, pSex, pBirthday, pJob, pLocation, pSchool, pLevel, pUnit, pWorkYear, pPhone, pCareer, pAwards, myPath As String

'循环变量

Dim i As Integer

'定义图形对象变量

Dim sp As Shape


Public Sub 按模板输出工作表()

    '设置工作簿为当前工作簿

    Set wb = Workbooks(1)

    '设置基础数据表、填表模板到表变量

    Set ws = Worksheets("数据")

    Set sh = Worksheets("模板")

    '关闭屏幕刷新

    'Application.ScreenUpdating = False

    '逐行读取人员基本信息，每行信息(即每个人的信息)填入表格后另存为单独文件

    For i = 2 To 3

        '设置数据表为当前激活的表格

        ws.Activate

        '将当前行各列单元格信息存至临时变量

        pName = Cells(i, 1).value

        pSex = Cells(i, 2).value

        pBirthday = Cells(i, 3).value

        pJob = Cells(i, 4).value

        pLocation = Cells(i, 5).value

        pSchool = Cells(i, 6).value

        pLevel = Cells(i, 7).value

        pUnit = Cells(i, 8).value

        pWorkYear = Cells(i, 9).value

        pPhone = Cells(i, 10).value

        pCareer = Cells(i, 11).value

        pAwards = Cells(i, 12).value

        '设置模板表格为当前激活的工作表

        sh.Activate

        '将临时变量信息写入模板对应单元格

        Cells(2, 2).value = pName

        Cells(2, 4).value = pSex

        Cells(2, 6).value = pBirthday

        Cells(3, 2).value = pJob

        Cells(3, 4).value = pLocation

        Cells(4, 2).value = pLevel

        Cells(4, 4).value = pSchool

        Cells(5, 2).value = pWorkYear

        Cells(5, 4).value = pUnit

        Cells(5, 6).value = pPhone

        Cells(6, 2).value = pCareer

        Cells(7, 2).value = pAwards

        '删除旧图片

        For Each sp In ActiveSheet.Shapes

            sp.Select

            '如果图形类别为13则是图片，删除，否则不删除，以免合并单元格被误删除

            If sp.Type = 13 Then

                sp.Delete

            End If

        Next

        '以当前文件所在目录为根目录，拼接文件完整路径

        myPath = imgPath & "证件照\" & pName & ".JPG"

        '调用插入图片的自定义方法

        insertPicture filename:=myPath, picCell:=Cells(2, 7), picLoc:="照片"

        '填好表信息的模板工作表复制为新工作表

        sh.Copy

        '活动工作表名以人员姓名命名

        ActiveSheet.Name = pName

        '文件另存至当前文件夹“\人员信息表\”子目录下

        ActiveWorkbook.SaveAs filename:=ThisWorkbook.Path & "\人员信息表\" & i - 1 & ".人员信息表(" & pName & ").xlsx"

        '关闭保存过的文件

        ActiveWorkbook.Close

    Next i

    '释放工作表和工作簿变量

    Set sh = Nothing

    Set ws = Nothing

    Set wb = Nothing

    '开启屏幕刷新

    'Application.ScreenUpdating = True

    '显示提示信息

    MsgBox "生成完毕,请到“人员信息表”目录下查看。"

End Sub


'自定义插入图片的方法

Sub insertPicture(ByRef filename As String, ByRef picCell As Range, ByRef picLoc As String)

    '判断指定路径下文件是否存在

    If Dir(filename) <> "" Then

        '插入图片

        ActiveSheet.Shapes.AddPicture(filename, msoFalse, msoTrue, picCell.Left, picCell.Top, -1, -1).Select

        '调整图片大小和位置

        With Selection.ShapeRange

            '锁定图片纵横比，避免变形

            .LockAspectRatio = msoTrue

            '上边缘比单元格上边缘多1个像素，避免遮盖边框线

            .Top = picCell.Top + 1

            '高度为单元格高度4倍减2像素，让出上下边缘线

            .Height = picCell.Height * 4 - 2

            '左边缘对齐位置

            .Left = picCell.Left + (picCell.Width - .Width) / 2

            '如果图片比例超宽，则宽度缩小到单元格宽,调整顶端对齐位置

            If .Width > picCell.Width Then

                '宽度调整为单元格宽减2像素

                .Width = picCell.Width - 2

                '左对齐到单元格左边缘加1像素

                .Left = picCell.Left + 1

                '上对齐向下调到居中位置

                .Top = picCell.Top + (picCell.Height * 4 - .Height) / 2

            End If

        End With

    Else

        Debug.Print pName & picLoc & "文件未找到。"

    End If

End Sub

4.运行效果

生成出的文档中证件照自动插入到模板规定位置。

#一次学一个小技巧，下班就数我最早#

如果对你有帮助，欢迎点赞、关注或转发。如果有其他更好的实现方法，欢迎回复与大家分享。