|
上一篇文章讲了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
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)
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
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
|
