【制作参赛卡】Word批量插入图片

上一篇文章讲了Word批量导出图片的案例，这节课讲一个图片批量导入图片的案例。

一、实际案例引入

我有一个制作Word参赛卡的需求，结果如截图所示：

每个队伍的图片来自于各个文件夹

每个队伍文件夹中，图片的命名都是：职位+姓名+身份证号

我需要做的就是，选择总文件夹，Word会自动把每个队伍文件夹下面的照片批量插入表格。这个就涉及到Word VBA批量插入图片的知识了。

二、思路及代码

大致思路我用流程图画了出来：

完整代码如下：

Sub 插入图片()
    Dim tb As Table, brr(), pic As InlineShape
    kk = 1
    Call 清除表格 '清空表格中原有的内容
    arr = Array("领队", "教练", "鼓手", "舵手", "划手", "替补", "空") '一维数组放置职位信息，为了自定义排序
    MsgBox "请选择图片文件夹！"
    Set FSO = CreateObject("scripting.filesystemobject")
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show Then PathSht = .SelectedItems(1) Else Exit Sub
    End With
    col = InputBox("生成几列照片？", "提示！", 5) '让用户输入需要生成多少列图片
    Set fl_name = FSO.getfolder(PathSht)
    For Each fl In fl_name.subfolders '对选择的文件夹里面所有队伍的文件夹进行遍历
        '-------------------------------------
        folnum = folnum + 1
        f_num = FSO.getfolder(fl.Path).Files.Count '获取每个队伍文件夹中照片的数量
        Selection.EndKey unit:=wdStory
        ActiveDocument.Paragraphs.Add
        Selection.MoveDown '(下)'以上3句是为了另起一行，输入新的数据
        Selection.TypeText fl.Name '输入队伍名称
        Selection.TypeParagraph
        ActiveDocument.Paragraphs.Add
        Selection.EndKey unit:=wdStory
        Set tb = ActiveDocument.Tables.Add(Selection.Range, (f_num \ col + 1) * 3, col) '新建表格
        tb.Style = "网格型" '表格类型为网格型，这种类型有黑色边框线
        For i = 1 To tb.Rows.Count Step 3 '对表格的行进行循环，设置表格高度
            tb.Rows(i).Height = 120
            tb.Rows(i + 1).Height = 15
            tb.Rows(i + 2).Height = 15
        Next
        '===================对人物照片进行自定义排序====================
        For a = 0 To UBound(arr) '将排序后的照片【全路径】写入数组brr
            For Each fil In FSO.getfolder(fl).Files
                If InStr(FSO.Getfile(fil).Name, arr(a)) Then
                    k = k + 1
                    ReDim Preserve brr(1 To k)
                    brr(k) = fil
                Else
                End If
            Next
        Next
        '===============================================================
        For i = 1 To ActiveDocument.Tables(folnum).Range.Cells.Count
            ActiveDocument.Tables(folnum).Range.ParagraphFormat.Alignment = wdAlignParagraphCenter '居中显示
            If ActiveDocument.Tables(folnum).Range.Cells(i).Row.Height = 120 And kk <= f_num Then '对于行高为120的单元格，插入图片
                Set pic = tb.Range.Cells(i).Range.InlineShapes.AddPicture(FileName:=brr(kk))
                pic.Width = tb.Range.Cells(i).Width - 10 '设置图片的宽度
                pic.Height = tb.Range.Cells(i).Height - 10 '设置图片的高度
                tb.Range.Cells(i + col).Range = Split(FSO.getbasename(brr(kk)), "+")(0) & "：" & Split(FSO.getbasename(brr(kk)), "+")(1) '写入职位
                tb.Range.Cells(i + col * 2).Range = Split(FSO.getbasename(brr(kk)), "+")(2) '写入身份证号
                kk = kk + 1
            Else
            End If
        Next
        '---------------------------
        k = 0: kk = 1: Erase brr
    Next
    MsgBox "完成！"
End Sub
Sub 清除表格()
    If ActiveDocument.Paragraphs.Count >= 2 Then
        ActiveDocument.Range(ActiveDocument.Paragraphs(2).Range.Start, ActiveDocument.Range.End).Delete
    Else
    End If
End Sub

运行过程：

三、知识点

■选择文件夹并遍历子文件夹

以下代码只能获取第一层子文件夹，如果要进一步获取子文件夹的子文件夹，需要递归。

Sub 获取子文件夹路径fso方法()
    Set fso = CreateObject("scripting.filesystemobject")
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show Then PathSht = .SelectedItems(1) Else Exit Sub
    End With
    Set f_num = fso.getfolder(PathSht)
    For Each fl In f_num.subfolders '遍历子文件夹
    MsgBox fl.Path '显示子文件夹路径
    Next
End Sub


■Word VBA批量插入图片，并调整尺寸

下段代码，根据自己需要去选择需要插入的图片，然后利用AddPicture方法，插入图片。

Sub 批量插入图片()
    Set myfile = Application.FileDialog(msoFileDialogFilePicker)
    With myfile
        If .Show = -1 Then
            For Each fn In .SelectedItems
                Set mypic = Selection.InlineShapes.AddPicture(FileName:=fn)
                mypic.Width = 28.345 * 6.3 '根据需要设置
                mypic.Height = 28.345 * 5.4
            Next fn
        End If
    End With
    Set myfile = Nothing
End Sub