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

lwz2019

1.我用原始图片试运行了一下，还是不行！

lwz2019

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

1.我用原始图片试运行了一下，还是不行！
2.这两天我也把您写的代码看了几遍，您是用原始图片的尺寸和数量分别赋值给arr数组，原始图片的名称赋值给brr数组，再根据图片尺寸和数量做条件循环判断后，再给图片赋值高宽的；
3.但是原始图片的尺寸收集回来，到了我手里大小完全不同！最少也会有3种尺寸（我上传的图片是因为网站要求附件不能大于2MB，我临时找图并更改压缩了的，这点可能误导了您）！所以只要原始图片的尺寸跟其他的相似他就无法更改宽度，或者是改成了相似条件的宽度
4.我在想能不能只用图片名称来循环判断赋值图片长宽？图片名1-3：高5.2、宽7.52；图片名4-5：高11、宽15、图片名6-9：高22.5、宽15；5.这是我个的看法，也不知道对不对，要真让我写，我几天都写不出来，还请老师再帮忙看看！

zldccmx

我是根据你的排版格局来定图片的宽度和高度的。
身份证、驾驶证：均为 正反面 2张小图 （1行2列） 高5.2*宽7.5
行驶证：2*2（2行2列） 高5.2*宽7.5
上岗证、验收合格证：1*1（一页2张） 高11*宽15
强制险商业险、验收表、安全协议书（一页一张） 高22.5

zldccmx

zldccmx

1. Sub zldccmx()
   
2.     Application.ScreenUpdating = False
   
3.     Dim Nd As Document, Tb As Table
   
4.     Set fso = CreateObject("Scripting.FileSystemObject")
   
5.     Set f = fso.GetFolder(ThisDocument.Path)
   
6.     pt = ThisDocument.Path & ""
   
7.     arr = Array("身份证,2_2", "驾驶证,2_2", "行驶证,4_2", "上岗证,1_2", "验收合格证,1_2", "强制险,1_1", "商业险,1_1", "验收表,1_1", "安全协议书,1_1")
   
8.     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")
   
9.     For Each E In f.SubFolders
   
10.         p = 0
    
11.         Set Nd = Documents.Open(pt & "封面模板.docx")
    
12.         With ActiveWindow.Selection
    
13.             .EndKey Unit:=6
    
14.             .InsertBreak Type:=2    '' 分节
    
15.             .EndKey Unit:=6    '回到文档末尾
    
16.             For I = 0 To UBound(arr)
    
17.                 ww = Split(arr(I), ",")
    
18.                 .Style = ActiveDocument.Styles("正文")
    
19.                 .Font.Size = 24
    
20.                 .Font.Name = "黑体"
    
21.                 .TypeText ww(0)    '"身份证"
    
22.                 .TypeParagraph
    
23.                 .Style = ActiveDocument.Styles("正文")
    
24.                 .Font.Size = 14
    
25.                 tpsl = Split(ww(1), "_")
    
26.                 cc = tpsl(1)    '尺寸
    
27.                 tpsl = tpsl(0)    '数量
    
28.                 If cc = 1 Then
    
29.                     If tpsl = 1 Then
    
30.                         rn = 1: cn = 1: rh = 22.5: cw = 15
    
31.                     Else
    
32.                         rn = 1: cn = 1: rh = 15
    
33.                     End If
    
34.                 Else
    
35.                     Select Case tpsl
    
36.                     Case 4
    
37.                         rn = 2: cn = 2: rh = 5.2: cw = 7.5
    
38.                     Case 2
    
39.                         rn = 1: cn = 2: rh = 5.2: cw = 7.5
    
40.                     Case 1
    
41.                         rn = 1: cn = 1: rh = 11: cw = 15
    
42.                     End Select
    
43.                 End If
    
44.                 Set Tb = ActiveDocument.Tables.Add(Range:=Selection.Range, NumRows:=rn, NumColumns:=cn, DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:=wdAutoFitFixed)
    
45.                 With Tb
    
46.                     .AutoFitBehavior wdAutoFitWindow
    
47.                     .AllowAutoFit = False    '关键语句,不允许表格宽度和高度变动
    
48.                     .Style = "网格型"
    
49.                     For j = 1 To 6
    
50.                         .Borders(j).LineStyle = wdLineStyleNone
    
51.                     Next
    
52.                     .Borders.Shadow = False
    
53.                     .Rows.WrapAroundText = True
    
54.                     .Columns.PreferredWidthType = wdPreferredWidthPoints
    
55.                     .Columns.PreferredWidth = CentimetersToPoints(cw)
    
56.                      If .Columns.Count > 1 Then .Columns.DistributeWidth '加个判断
    
57.                     .Rows.HeightRule = wdRowHeightExactly
    
58.                     .Rows.Height = CentimetersToPoints(rh)
    
59.                 End With
    
60.                 .EndKey Unit:=6
    
61.                 For k = 1 To tpsl
    
62.                     Select Case k
    
63.                     Case 1
    
64.                         Tb.Cell(1, 1).Select: .MoveLeft , 1
    
65.                         Set Pic = .InlineShapes.AddPicture(FileName:=E & "" & brr(p), LinkToFile:=False, SaveWithDocument:=True)
    
66.                         Pic.LockAspectRatio = False
    
67.                         Pic.Height = Tb.Rows(1).Height - 2
    
68.                         Pic.Width = Tb.Columns(1).Width - 2
    
69.                     Case 2
    
70.                         Tb.Cell(1, 2).Select: .MoveLeft , 1
    
71.                         Set Pic = .InlineShapes.AddPicture(FileName:=E & "" & brr(p), LinkToFile:=False, SaveWithDocument:=True)
    
72.                         Pic.LockAspectRatio = False
    
73.                         Pic.Height = Tb.Rows(1).Height
    
74.                         Pic.Width = Tb.Columns(2).Width - 2
    
75.                     Case 3
    
76.                         Tb.Cell(2, 1).Select: .MoveLeft , 1
    
77.                         Set Pic = .InlineShapes.AddPicture(FileName:=E & "" & brr(p), LinkToFile:=False, SaveWithDocument:=True)
    
78.                         Pic.LockAspectRatio = False
    
79.                         Pic.Height = Tb.Rows(1).Height
    
80.                         Pic.Width = Tb.Columns(1).Width - 2
    
81.                     Case 4
    
82.                         Tb.Cell(2, 2).Select: .MoveLeft , 1
    
83.                         Set Pic = .InlineShapes.AddPicture(FileName:=E & "" & brr(p), LinkToFile:=False, SaveWithDocument:=True)
    
84.                         Pic.LockAspectRatio = False
    
85.                         Pic.Width = Tb.Columns(2).Width - 2
    
86.                         Pic.Height = Tb.Rows(1).Height
    
87.                     End Select
    
88.                     p = p + 1
    
89.                 Next
    
90.                 .EndKey Unit:=6
    
91.             Next
    
92.         End With
    
93.         Nd.SaveAs2 E & ".docx", fileformat:=16
    
94.     Next
    
95.     Application.ScreenUpdating = True
    
96.     MsgBox "整理完事，个别图片需要手工调整一下即可。"
    
97. End Sub
    

复制代码

lwz2019

zldccmx 发表于 2021-9-5 16:51

是的，但是我如果给身份证或行驶证换张大图（比如跟商业险或者强制险大小一样），图片的宽度还是判断为15，而不是7.52；高度倒是改成5.2了，就是不明白为什么？

zldccmx

重新上传了，代码稍作改动。

zldccmx

8楼、9楼提示的那一段就不需要了

lwz2019

zldccmx 发表于 2021-9-5 17:12
8楼、9楼提示的那一段就不需要了

干得漂亮！成了！真是感谢老师的鼎力帮助!我瞎琢磨穷捣鼓了几天，您就加了两句代码就成了；佩服！佩服！看样子我革命的道路还长着呢！再次感谢您的帮助

ytmf0149

zldccmx，wordvba太牛了