如何实现Word 中批量插入图片
发布网友
发布时间：2022-04-22 03:00
共1个回答
热心网友
时间：2023-09-19 04:04
Sub 批量添加图片()
'程序功能：批量添加图片宏
'作者Q：766110727
'日期：2017.06.07
'使用步骤1：word中ALT+11进入VBA宏界面；
'使用步骤2：将本段代码从sub到end sub，全部粘到代码框最后的空白处；
'使用步骤3：按F5执行代码。
'说明：代码按最直观的逻辑写的，也方便大家使用修改。
'On Error Resume Next
Dim n, 图片路径1(), 图片路径2(), 图片路径3(), 图片路径4(), 图片数量最大值
Dim myTable As Table
'###################################################################
'#######第一部分：获取每个文件夹下所有jpg图片名，写入相应数组#######
'###################################################################
n = 0
图1 = Dir("I:\tt\jbt\插入图片\图片\*.jpg")
Do While 图1 <> ""
n = n + 1
ReDim Preserve 图片路径1(1 To n)
图片路径1(n) = "I:\tt\jbt\插入图片\图片\" & 图1
图1 = Dir()
Loop
If n > 图片数量最大值 Then 图片数量最大值 = n
n = 0
图2 = Dir("I:\tt\jbt\插入图片\图片2\*.jpg")
Do While 图2 <> ""
n = n + 1
ReDim Preserve 图片路径2(1 To n)
图片路径2(n) = "I:\tt\jbt\插入图片\图片2\" & 图2
图2 = Dir()
Loop
If n > 图片数量最大值 Then 图片数量最大值 = n
n = 0
图3 = Dir("I:\tt\jbt\插入图片\图片3\*.jpg")
Do While 图3 <> ""
n = n + 1
ReDim Preserve 图片路径3(1 To n)
图片路径3(n) = "I:\tt\jbt\插入图片\图片3\" & 图3
图3 = Dir()
Loop
If n > 图片数量最大值 Then 图片数量最大值 = n
n = 0
图4 = Dir("I:\tt\jbt\插入图片\图片4\*.jpg")
Do While 图4 <> ""
n = n + 1
ReDim Preserve 图片路径4(1 To n)
图片路径4(n) = "I:\tt\jbt\插入图片\图片4\" & 图4
图4 = Dir()
Loop
If n > 图片数量最大值 Then 图片数量最大值 = n
'###################################################################
'##################第二部分：插入图片到word表格中###################
'###################################################################
'新建一个一行两列表格
Set myTable = ActiveDocument.Tables.Add(Range:=ActiveDocument.Range(Start:=0, End:=0), NumRows:=1, NumColumns:=2)
'设定后续操作的目标表格为文档的第一个表格
Set myTable = ActiveDocument.Tables(1)
n = 0
Do While n < 图片数量最大值
n = n + 1
之前表格行数 = myTable.Rows.Count
myTable.Rows.Last.Select
Selection.InsertRowsBelow 4 '下方插入4行
'第一行两列，图片序号12
myTable.Cell(Row:=之前表格行数 + 1, Column:=1).Range.InsertAfter Text:="图片 1"
myTable.Cell(Row:=之前表格行数 + 1, Column:=2).Range.InsertAfter Text:="图片 2"
myTable.Cell(Row:=之前表格行数 + 3, Column:=1).Range.InsertAfter Text:="图片 3"
myTable.Cell(Row:=之前表格行数 + 3, Column:=2).Range.InsertAfter Text:="图片 4"
'第二行两列，插入图片并设置图片大小
myTable.Cell(Row:=之前表格行数 + 2, Column:=1).Range.InlineShapes.AddPicture FileName:= _
图片路径1(n), LinkToFile:=False, SaveWithDocument:=True
myTable.Cell(Row:=之前表格行数 + 2, Column:=2).Range.InlineShapes.AddPicture FileName:= _
图片路径2(n), LinkToFile:=False, SaveWithDocument:=True
myTable.Cell(Row:=之前表格行数 + 4, Column:=1).Range.InlineShapes.AddPicture FileName:= _
图片路径3(n), LinkToFile:=False, SaveWithDocument:=True
myTable.Cell(Row:=之前表格行数 + 4, Column:=2).Range.InlineShapes.AddPicture FileName:= _
图片路径4(n), LinkToFile:=False, SaveWithDocument:=True
Loop
ActiveDocument.Tables(1).Rows(1).Delete '刚开始建的表格中第一行是空行，删掉
'###################################################################
'######################第三部分：图片格式处理#######################
'###################################################################
'统一设置图片长宽，美化文档。这里会卡好久时间，按需要是否添加本段代码
For n = 1 To ActiveDocument.InlineShapes.Count
ActiveDocument.InlineShapes(n).Height = 210 '设置高度
ActiveDocument.InlineShapes(n).Width = 110 '设置宽度
Next n
End Sub
