为了工作方便，写了一个根据相片名称，自动生成表单的工具。
工具是office word 里面自带的vba。wps应该也正常使用。
原理是，很多相片，需要生成一张张表单，看相片改名字比较方便，于是借鉴网络代码加自己改造出来下列代码。
需要在word里，打开开发工具，然后用宏或者virtual basic里插入模块，复制下列代码，然后F5或者点运行，根据提示操作即可。
图片名称以 - 分割，代码会逐行填入内容。需要改的地方都有注释了，自己尝试，不明白可以跟帖问一下。
生成表格效果，行列均可改，列数对话框输入即可。
图片原文件文件名实例（也可以随便改）
[Visual Basic] 纯文本查看 复制代码 Sub imgTbl()
currentDate = Date
' 将当前日期作为文本插入到光标位置
'Selection.TypeText Text:=currentDate & " "
Selection.TypeText Text:="问题整改通知与记录，编制日期：" & currentDate
Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
Dim nrr
If ActiveDocument.Tables.Count = 1 Then '删除上次数据
ActiveDocument.Tables(1).Delete
End If
'//获取文件夹，存入数组
Dim kr()
Set fso = CreateObject("scripting.filesystemobject")
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show Then PathSht = .SelectedItems(1) Else Exit Sub
End With
Dim imgPaths() '图片路径数组
picname = Dir(PathSht & "\*.*")
Do While picname <> "" 'Do While循环
i = i + 1
imgpath = PathSht + "\" + picname
picname = Dir ' 查找下一个图片
ReDim Preserve imgPaths(1 To i)
imgPaths(i) = imgpath
'Debug.Print (imgpath)
Loop
imgnum = UBound(imgPaths) + 1
Dim value '弹出输入框，输入列数，默认10，会自动计算行数
value = InputBox("请输入表格列数", "表格列数", "10")
'Debug.Print value
tbl_columnNum = value
tbl_rowNum = (Int(imgnum / tbl_columnNum)) * 8
'//开始新建表格
Dim tbl As Table
Set tbl = ActiveDocument.Tables.Add(Range:=Selection.Range, NumRows:=tbl_rowNum, NumColumns:=tbl_columnNum)
'新建表格
tbl.Style = "网格型"
Set tbl = ActiveDocument.Tables(1)
tbl.Rows.Height = 20
'tbl.Columns(1).Width = 1.27 * 28.35 '设置表格各列的列宽
'tbl.Columns(2).Width = 2.13 * 28.35
'tbl.Columns(3).Width = 3.3 * 28.35
'tbl.Rows(1).Height = 2.13 * 28.35 '设置表格各列的列宽
tbl.Rows.Alignment = wdAlignRowCenter '居中对齐
tbl.Range.Cells.VerticalAlignment = wdCellAlignVerticalCenter '文字垂直居中
'tbl.Range.HorizontalInVertical = xlHAlignCenter '文字水平居中
'tbl.Range.Rows.Alignment = wdAlignRowCenter
tbl.Range.ParagraphFormat.Alignment = wdAlignParagraphLeft '文字水平居中
tbl.Range.Font.Size = 10
'//开始插入图片
For i = 1 To tbl_rowNum
'对Word中的表格中的行进行循环。
For j = 1 To tbl_columnNum
'对Word中的表格中的列进行循环。
fod_index = fod_index + 1
If fod_index >= imgnum Then ' 超过图片数量，退出循环
Exit For
End If
imgpath = imgPaths(fod_index) '图片路径
srr = Split(imgpath, "\")
FullName = srr(UBound(srr))
nrr = Split(FullName, ".")
picname = nrr(0)
nrr = Split(nrr(0), "-")
ReDim Preserve nrr(0 To 6)
'tbl.Cell(i, j).Range.Text = nrr(0) '单元格文字图片名称不带后缀
'tbl.Cell(i, j).Range.Text = "OK"
nrr(3) = picname
nrr(4) = " "
nrr(5) = " "
nrr(6) = " "
tbl.Cell(i * 8 - 7, j).Range.Select '选择当前单元格
Dim shp As InlineShape
Set shp = Selection.Range.InlineShapes.AddPicture(FileName:=imgpath) '插入图片
Selection.EndKey wdLine
'tbl.Cell(i * 5, j).Range.Select '选择当前单元格 '选中该单元格，为了下一步光标定位到单元格内部
bt = Array("问题描述：", "责任单位：", "需整改完成时间：", "图片名称:", "实际完成时间：", "整改自检人及时间：", "验证人及验证时间：")
For m = 0 To 6
tbl.Cell((i - 1) * 8 + m + 2, j).Range.Select
Selection.EndKey wdLine
Selection.TypeText bt(m) & nrr(m)
Next m
' tbl.Cell(i * 5 - 3, j).Range.Select
' Selection.EndKey wdLine
' Selection.TypeText "问题描述：" & nrr(0) '单元格文字图片名称不带后缀
' tbl.Cell(i * 5 - 2, j).Range.Select
' Selection.EndKey wdLine
' Selection.TypeText "责任单位：" & nrr(1) '单元格文字图片名称不带后缀
' tbl.Cell(i * 5 - 1, j).Range.Select
' Selection.EndKey wdLine
' Selection.TypeText "整改时间：" & nrr(2) '单元格文字图片名称不带后缀
' tbl.Cell(i * 5, j).Range.Select
' Selection.EndKey wdLine
'Selection.TypeText "整改完成时间及验证人签字：" & nrr(4) '单元格文字图片名称不带后缀
Next
Next
For t = 1 To Int(imgnum / 2) - 1
Set tbl = ActiveDocument.Tables(t) '将第一个表格赋值给变量tbl
If Not IsNull(tbl) Then '如果存在表格
tbl.Rows(9).Select '选择第二行（索引从1开始）
Selection.SplitTable
Selection.InsertBreak Type:=wdPageBreak
Selection.TypeText Text:="问题整改通知与记录，编制日期：" & currentDate
Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
'Selection.MoveDown Unit:=wdLine, Count:=1
Else
MsgBox "当前文档没有任何表格。"
End If
Next t
Selection.HomeKey Unit:=wdStory
MsgBox "完成！"
End Sub
Function getfol()
'该函数的作用：弹出对话框提示用户选择文件夹，并且返回该文件夹路径。
'如果用户选择了取消，则返回空值
Dim PathSht As String
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show Then
PathSht = .SelectedItems(1)
Else
PathSht = ""
Exit Function
End With
getfol = PathSht & IIf(Right(PathSht, 1) = "\", "", "\")
End Function | 
发表于 2024-4-2 22:41
