调整VBA代码实现Word文档3列图片与文件名插入功能

原VBA代码用于生成2列的图片+文件名表格，修改为3列布局后出现第3列无法填充、布局混乱的问题。以下是修复后的代码，可实现每行3张图片，每张图片下方对应显示文件名的效果。

修复后的完整代码 #

主程序：AddPics #

Sub AddPics()
    Application.ScreenUpdating = False
    Dim oTbl As Table, i As Long, j As Long, k As Long, StrTxt As String
    
    '选择并插入图片
    With Application.FileDialog(msoFileDialogFilePicker)
        .Title = "选择图片文件后点击确定"
        .Filters.Add "图片文件", "*.gif; *.jpg; *.jpeg; *.bmp; *.tif; *.png"
        .FilterIndex = 2
        If .Show = -1 Then
            '创建初始2行3列的表格，列宽5厘米
            Set oTbl = Selection.Tables.Add(Selection.Range, 2, 3)
            With oTbl
                .AutoFitBehavior (wdAutoFitFixed)
                .Columns.Width = CentimetersToPoints(5)
                '格式化初始行
                Call FormatRows(oTbl, 1)
            End With
            
            '确保"Picture"题注标签存在，避免重复创建报错
            On Error Resume Next
            CaptionLabels.Add Name:="Picture"
            On Error GoTo 0
            
            For i = 1 To .SelectedItems.Count
                '计算当前图片所在的图片行（每组两行：图片行+标题行）
                j = Int((i - 1) / 3) * 2 + 1
                '计算当前图片所在的列号（1-3循环）
                k = (i - 1) Mod 3 + 1
                
                '当现有行数不足时，新增两行（图片行+标题行）
                If j > oTbl.Rows.Count Then
                    oTbl.Rows.Add
                    oTbl.Rows.Add
                    Call FormatRows(oTbl, j)
                End If
                
                '插入图片到对应单元格
                ActiveDocument.InlineShapes.AddPicture _
                  FileName:=.SelectedItems(i), LinkToFile:=False, _
                  SaveWithDocument:=True, Range:=oTbl.Rows(j).Cells(k).Range
                
                '提取文件名（修复原代码双反斜杠的错误）
                StrTxt = Split(.SelectedItems(i), "\")(UBound(Split(.SelectedItems(i), "\")))
                StrTxt = ": " & StrTxt
                '若只需文件名不含后缀，可替换为下面一行
                'StrTxt = ": " & Split(StrTxt, ".")(0)
                
                '在图片下方的单元格插入题注
                With oTbl.Rows(j + 1).Cells(k).Range
                    .InsertBefore vbCr
                    .Characters.First.InsertCaption _
                      Label:="Picture", Title:=StrTxt, _
                      Position:=wdCaptionPositionBelow, ExcludeLabel:=False
                    .Characters.First = vbNullString
                    .Characters.Last.Previous = vbNullString
                End With
            Next i
        End If
    End With
    
    Application.ScreenUpdating = True
End Sub

辅助格式化程序：FormatRows #

Sub FormatRows(oTbl As Table, x As Long)
    With oTbl
        '格式化图片行：固定高度5厘米
        With .Rows(x)
            .Height = CentimetersToPoints(5)
            .HeightRule = wdRowHeightExactly
            .Range.Style = "Normal"
        End With
        
        '格式化标题行：固定高度0.5厘米，应用题注样式
        With .Rows(x + 1)
            .Height = CentimetersToPoints(0.5)
            .HeightRule = wdRowHeightExactly
            .Range.Style = "Caption"
        End With
    End With
End Sub

关键修改说明 #

• 行列计算逻辑适配3列：原代码的行号j和列号k是为2列设计的，修改后通过Int((i-1)/3)*2+1计算每组图片的起始行，(i-1) Mod 3 +1循环1-3列，确保图片正确填充到每行3个单元格中
• 文件名提取错误修复：原代码中使用双反斜杠\\分割路径，导致无法正确提取文件名，改为单反斜杠\后可正常获取文件名
• 题注标签容错处理：添加错误捕获逻辑，避免重复创建"Picture"题注标签时触发报错

内容的提问来源于stack exchange，提问作者Peter B