代码功能：Word中批量插入图片，并且，图片下方展示具体的图片名字或者更详细的信息。支持图片插入后的自定义列数。可直接转化为VSTO代码。
Sub t()
Set wd = Application
Dim h As Integer
Dim n As Integer
Dim M As Integer
Dim picrow As Integer
Dim picname As String
Dim picwidth
Dim i
Dim prr
Dim pagewidth As Double
wd.ScreenUpdating = False
Dim a
Dim P As Word.InlineShape
Dim t As Word.Table
If wd.Selection.Information(12) = True Then MsgBox ("请将光标置于表格之外！"): Exit Sub
pagewidth = wd.ActiveDocument.PageSetup.pagewidth - wd.ActiveDocument.PageSetup.LeftMargin - wd.ActiveDocument.PageSetup.RightMargin
With wd.FileDialog(3)
.Title = "请选择..."
If .Show = -1 Then
n = Val(InputBox("请输入表格的列数：", "列数", 3))
picrow = Val(InputBox("请输入图片信息总行数：" & vbCrLf & "例如：" & vbCrLf & vbCrLf & "张三+20220209+天津市" & vbCrLf & "这种就输入3" & vbCrLf & vbCrLf & "张三+天津市" & vbCrLf & "这种就输入2", "行数", 3))
If Val(n) = 0 Then Exit Sub
If Val(picrow) = 0 Then Exit Sub
M = .SelectedItems.Count
'h = IIf(M / n = Int(M / n), 2 * M / n, 2 * (Int(M / n) + 1))
'有余数就+1，没有余数不需加1
h = IIf(M / n = Int(M / n), (picrow + 1) * M / n, (picrow + 1) * (Int(M / n) + 1))
Set t = wd.ActiveDocument.Tables.Add(wd.Selection.Range, h, n)
t.Borders.Enable = True
t.Borders.OutsideLineStyle = 7
For Each a In .SelectedItems
picname = GetFileInfo(a, 2)
prr = Split(picname, "+")
Set P = wd.Selection.InlineShapes.AddPicture(FileName:=a, SaveWithDocument:=True)
With P
picwidth = .Width
.Width = Int(pagewidth / n)
.Height = .Width * .Height / picwidth
End With
i = i + 1
'移动光标写入内容，设置内容居中显示
wd.Selection.MoveLeft 1, 1
For j = 0 To UBound(prr)
wd.Selection.MoveDown 5, 1
wd.Selection.TypeText (prr(j))
wd.Selection.Cells(1).Select
wd.Selection.ParagraphFormat.Alignment = 1 '决定了首行居中
Next
'/
wd.Selection.HomeKey
wd.Selection.MoveUp 5, UBound(prr) + 1
wd.Selection.MoveRight 1, 2
'Debug.Print i, n
'/换行操作替代
If i = Val(n) Then
Dim activetbl As Word.Table
Dim activerow As Integer
activerow = Selection.Information(wdStartOfRangeRowNumber)
Set activetbl = Selection.Tables(1)
activetbl.Cell(activerow + picrow + 1, 1).Select
'wd.Selection.MoveRight 1, 1
'wd.Selection.Cells(1).Select
'wd.Selection.EndKey
'wd.Selection.MoveDown 5, UBound(prr) + 1
i = 0
End If
Next
End If
End With
wd.ScreenUpdating = True
MsgBox "完成！共导入" & M & "张图片。", vbInformation, "Word魔方"
'Catch
' MsgBox(Err.Description)
' wd.ScreenUpdating = True
'End Try
End Sub插入效果展示：
