怎样用vba根据word模版的要求将图片分类批量插入？

lwz2019 · 发表于 2021-9-2 13:04

本帖最后由 lwz2019 于 2021-9-2 14:21 编辑

1.根据文件夹名新建对应名称的word文档（同目录即可）;
2.将“封面模版”的内容拷贝到新建的word文档的首页;
3.将对应名称文件夹里的图片，按分类依次插入，每个新建的word完成后的字体、图片格式大小与“车辆档案模版”相同.4.图片1-9分别代表：1.身份证、2.驾驶证、3.行驶证、4.上岗证、5.验收合格证、6.强制险、7.商业险、8.验收表、9.安全协议书
5.图片量较大也涉及到隐私，我就不上传了，用的是风景图片替代的，看起来会比较费劲，拜请给位老师帮我看看，先谢了！

zldccmx · 发表于 2021-9-2 20:14

Sub zldccmx()
Application.ScreenUpdating = False
Dim Nd As Document, Tb As Table
Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.GetFolder(ThisDocument.Path)
pt = ThisDocument.Path & ""
arr = Array("身份证,2_2", "驾驶证,2_2", "行驶证,4_2", "上岗证,1_2", "验收合格证,1_2", "强制险,1_1", "商业险,1_1", "验收表,1_1", "安全协议书,1_1")
brr = Array("1-1.jpg", "1-2.jpg", "2-1.jpg", "2-2.jpg", "3-1.jpg", "3-2.jpg", "3-3.jpg", "3-4.jpg", "4.jpg", "5.jpg", "6.jpg", "7.jpg", "8.jpg", "9.jpg")
p = 0
For Each E In f.SubFolders
Set Nd = Documents.Open(pt & "封面模板.docx")
With ActiveWindow.Selection
.EndKey Unit:=6
.InsertBreak Type:=2 '' 分节
.EndKey Unit:=6 '回到文档末尾
For I = 0 To UBound(arr)
ww = Split(arr(I), ",")
.Style = ActiveDocument.Styles("正文")
.Font.Size = 24
.Font.Name = "黑体"
.TypeText ww(0) '"身份证"
.TypeParagraph
.Style = ActiveDocument.Styles("正文")
.Font.Size = 14
tpsl = Split(ww(1), "_")
cc = tpsl(1) '尺寸
tpsl = tpsl(0) '数量
If cc = 1 Then
If tpsl = 1 Then
rn = 1: cn = 1: rh = 22.5
Else
rn = 1: cn = 1: rh = 15
End If
Else
Select Case tpsl
Case 4
rn = 2: cn = 2: rh = 5.2: cw = 7.5
Case 2
rn = 1: cn = 2: rh = 5.2: cw = 7.5
Case 1
rn = 1: cn = 1: rh = 11: cw = 15
End Select
End If
Set Tb = ActiveDocument.Tables.Add(Range:=Selection.Range, NumRows:=rn, NumColumns:=cn, DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:=wdAutoFitFixed)
With Tb
.AutoFitBehavior wdAutoFitWindow
.Style = "网格型"
For j = 1 To 6
.Borders(j).LineStyle = wdLineStyleNone
Next
.Borders.Shadow = False
.Rows.WrapAroundText = True
.Columns.PreferredWidthType = wdPreferredWidthPoints
.Columns.PreferredWidth = CentimetersToPoints(cw)
.Rows.HeightRule = wdRowHeightExactly
.Rows.Height = CentimetersToPoints(rh)
End With
.EndKey Unit:=6
For k = 1 To tpsl
Select Case k
Case 1
Tb.Cell(1, 1).Select: .MoveLeft , 1
Set Pic = .InlineShapes.AddPicture(FileName:=E & "" & brr(p), LinkToFile:=False, SaveWithDocument:=True)
Pic.LockAspectRatio = False
Pic.Height = Tb.Rows(1).Height - 2
Pic.Width = Tb.Columns(1).Width - 2
Case 2
Tb.Cell(1, 2).Select: .MoveLeft , 1
Set Pic = .InlineShapes.AddPicture(FileName:=E & "" & brr(p), LinkToFile:=False, SaveWithDocument:=True)
Pic.LockAspectRatio = False
Pic.Height = Tb.Rows(1).Height
Pic.Width = Tb.Columns(2).Width - 2
Case 3
Tb.Cell(2, 1).Select: .MoveLeft , 1
Set Pic = .InlineShapes.AddPicture(FileName:=E & "" & brr(p), LinkToFile:=False, SaveWithDocument:=True)
Pic.LockAspectRatio = False
Pic.Height = Tb.Rows(1).Height
Pic.Width = Tb.Columns(1).Width - 2
Case 4
Tb.Cell(2, 2).Select: .MoveLeft , 1
Set Pic = .InlineShapes.AddPicture(FileName:=E & "" & brr(p), LinkToFile:=False, SaveWithDocument:=True)
Pic.LockAspectRatio = False
Pic.Width = Tb.Columns(2).Width - 2
Pic.Height = Tb.Rows(1).Height
End Select
p = p + 1
Next
.EndKey Unit:=6
Next
End With
Nd.SaveAs2 E & ".docx", fileformat:=16
Next
Application.ScreenUpdating = True
MsgBox "整理完事，个别图片需要手工调整一下即可。"
End Sub

复制代码

zldccmx · 发表于 2021-9-2 20:15

本帖最后由 zldccmx 于 2021-9-2 20:22 编辑

详见附件！

zldccmx · 发表于 2021-9-2 20:18

此文件必须与封面模板文档存放在一起，位于车辆信息分类之上的目录。如图：

zldccmx · 发表于 2021-9-2 20:28

lwz2019 · 发表于 2021-9-2 21:20

zldccmx 发表于 2021-9-2 20:18
此文件必须与封面模板文档存放在一起，位于车辆信息分类之上的目录。如图：

感谢老师的提醒！代码我运行了一下，如同老师所说只有几张小图需要调整一下就行了，其他的完全达到预期！就是信息量有点大，我还得慢慢领悟！再次感谢您的帮助！多谢了！

lwz2019 · 发表于 2021-9-3 17:13

本帖最后由 lwz2019 于 2021-9-3 20:17 编辑

zldccmx 发表于 2021-9-2 20:28

老师我今天用原始图片调试一下，发现第二页图片需要调整，主要是因为左边第一列的图片宽度都给设置上成了15（而实际应该要5.2，高度7.52没错），而第二列设置都对？我手动修改后（没改前所有图片宽度显示的是15左右，改后是7.52），如图就好了！本人初学vba，看了您的代码，改了半天也不对，主要是好多代码的意思还没弄懂！麻烦您再帮忙看看！应该怎样修改一下才行！

zldccmx · 发表于 2021-9-5 14:47

Sub zldccmx()
Application.ScreenUpdating = False
Dim Nd As Document, Tb As Table
Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.GetFolder(ThisDocument.Path)
pt = ThisDocument.Path & ""
arr = Array("身份证,2_2", "驾驶证,2_2", "行驶证,4_2", "上岗证,1_2", "验收合格证,1_2", "强制险,1_1", "商业险,1_1", "验收表,1_1", "安全协议书,1_1")
brr = Array("1-1.jpg", "1-2.jpg", "2-1.jpg", "2-2.jpg", "3-1.jpg", "3-2.jpg", "3-3.jpg", "3-4.jpg", "4.jpg", "5.jpg", "6.jpg", "7.jpg", "8.jpg", "9.jpg")
For Each E In f.SubFolders
p = 0
Set Nd = Documents.Open(pt & "封面模板.docx")
With ActiveWindow.Selection
.EndKey Unit:=6
.InsertBreak Type:=2 '' 分节
.EndKey Unit:=6 '回到文档末尾
For I = 0 To UBound(arr)
ww = Split(arr(I), ",")
.Style = ActiveDocument.Styles("正文")
.Font.Size = 24
.Font.Name = "黑体"
.TypeText ww(0) '"身份证"
.TypeParagraph
.Style = ActiveDocument.Styles("正文")
.Font.Size = 14
tpsl = Split(ww(1), "_")
cc = tpsl(1) '尺寸
tpsl = tpsl(0) '数量
If cc = 1 Then
If tpsl = 1 Then
rn = 1: cn = 1: rh = 22.5
Else
rn = 1: cn = 1: rh = 15
End If
Else
Select Case tpsl
Case 4
rn = 2: cn = 2: rh = 5.2: cw = 7.5
Case 2
rn = 1: cn = 2: rh = 5.2: cw = 7.5
Case 1
rn = 1: cn = 1: rh = 11: cw = 15
End Select
End If
Set Tb = ActiveDocument.Tables.Add(Range:=Selection.Range, NumRows:=rn, NumColumns:=cn, DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:=wdAutoFitFixed)
With Tb
.AutoFitBehavior wdAutoFitWindow
.Style = "网格型"
For j = 1 To 6
.Borders(j).LineStyle = wdLineStyleNone
Next
.Borders.Shadow = False
.Rows.WrapAroundText = True
.Columns.PreferredWidthType = wdPreferredWidthPoints
.Columns.PreferredWidth = CentimetersToPoints(cw)
.Rows.HeightRule = wdRowHeightExactly
.Rows.Height = CentimetersToPoints(rh)
End With
.EndKey Unit:=6
For k = 1 To tpsl
Select Case k
Case 1
Tb.Cell(1, 1).Select: .MoveLeft , 1
Set Pic = .InlineShapes.AddPicture(FileName:=E & "" & brr(p), LinkToFile:=False, SaveWithDocument:=True)
Pic.LockAspectRatio = False
Pic.Height = Tb.Rows(1).Height - 2
Pic.Width = Tb.Columns(1).Width - 2
Case 2
Tb.Cell(1, 2).Select: .MoveLeft , 1
Set Pic = .InlineShapes.AddPicture(FileName:=E & "" & brr(p), LinkToFile:=False, SaveWithDocument:=True)
Pic.LockAspectRatio = False
Pic.Height = Tb.Rows(1).Height
Pic.Width = Tb.Columns(2).Width - 2
Case 3
Tb.Cell(2, 1).Select: .MoveLeft , 1
Set Pic = .InlineShapes.AddPicture(FileName:=E & "" & brr(p), LinkToFile:=False, SaveWithDocument:=True)
Pic.LockAspectRatio = False
Pic.Height = Tb.Rows(1).Height
Pic.Width = Tb.Columns(1).Width - 2
Case 4
Tb.Cell(2, 2).Select: .MoveLeft , 1
Set Pic = .InlineShapes.AddPicture(FileName:=E & "" & brr(p), LinkToFile:=False, SaveWithDocument:=True)
Pic.LockAspectRatio = False
Pic.Width = Tb.Columns(2).Width - 2
Pic.Height = Tb.Rows(1).Height
End Select
p = p + 1
Next
.EndKey Unit:=6
Next
''''''''''''''''''''''''''''''''''
'加入以下这个循环
For Each t In Nd.Tables
If t.Range.Columns.Count > 1 Then t.Range.Cells.DistributeWidth
Next
''''''''''''''''''''''''''''''''''''''''''''
End With
Nd.SaveAs2 E & ".docx", fileformat:=16
Next
Application.ScreenUpdating = True
MsgBox "整理完事，个别图片需要手工调整一下即可。"
End Sub

复制代码

zldccmx · 发表于 2021-9-5 14:49

lwz2019 · 发表于 2021-9-5 15:27

zldccmx 发表于 2021-9-5 14:49

好的，我试试！

		自动登录	找回密码
密码			免费注册

[求助] 怎样用vba根据word模版的要求将图片分类批量插入？

评分