利用vba来快速以表格形式插入图片名＋图片

word

vba

打开Word，注意不是wps。

将下面代码粘贴进去：Sub 每行插入表格n个图()        On Error Resume Next    Application.ScreenUpdating = False    Dim D As FileDialog, a, p As InlineShape, t As Table    If Selection.Information(wdWithInTable) = True Then MsgBox '请将光标置于表格之外！': Exit Sub    With Application.FileDialog(msoFileDialogFilePicker)        '        .InitialFileName = 'D:\'        .Title = '请选择...'        If .Show = -1 Then            n = InputBox('请输入表格的列数：', '列数', 3)            mc = InputBox('是否同时插入名称？', '名称', 1)            m = .SelectedItems.Count            Debug.Print '共有' & m & '个图片'; m            '        If m / n <> Int(m / n) Then            '        h = 2 * (Int(m / n) + 1)            '        Else: h = 2 * m            '        End If            If mc = 1 Then            h = IIf(m / n = Int(m / n), 2 * m / n, 2 * (Int(m / n) + 1))            Else            h = IIf(m / n = Int(m / n), m / n, (Int(m / n) + 1))            End If            '   Debug.Print h, m            Set t = ActiveDocument.Tables.Add(Selection.Range, h, n)            t.Borders.Enable = True            '        t.Borders.InsideColor = wdColorBlue            '        t.Borders.OutsideColor = wdColorRed            t.Borders.OutsideLineStyle = wdLineStyleDouble            For Each a In .SelectedItems                Set p = Selection.InlineShapes.AddPicture(FileName:=a, SaveWithDocument:=True)                With p                    W = .Width                    .Width = Int(410 / n)                    .Height = .Width * .Height / W                End With                i = i + 1                If mc = 1 Then                b = Split(a, '\')(UBound(Split(a, '\')))    '或修改成b.name                c = Split(b, '.')(0)                Selection.MoveLeft wdCharacter, 1 '光标移到到图片左边                Selection.MoveDown wdLine, 1 '光标下移到下面的单元格                Selection.TypeText c '键入文件名                Selection.Cells(1).Select                Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter    '决定了首行居中                Selection.HomeKey                Selection.MoveDown wdLine, -1 '光标上移                Selection.MoveRight wdCharacter, 2 '光标右移两个单元，到右边单元格                Else                Selection.MoveRight wdCharacter, 1 '光标右移两个单元，到右边单元格                End If                Debug.Print i, n'                If i = Val(n) And mc = 1 Then '不可这样写，会跳过单元格                 If i = Val(n) Then                        If mc = 1 Then                        Selection.MoveRight wdCharacter, 1                        Selection.Cells(1).Select                        Selection.EndKey                        Selection.MoveDown wdLine, 1                        i = 0                    Else                         Selection.MoveRight wdCharacter, 1                         i = 0                    End If                End If            Next        End If    End With    Application.ScreenUpdating = True    If Err.Number <> 0 Then MsgBox '中间有错误产生！'End Sub

图片示意：

按F5运行，于是会弹出图片选择的窗口：

选择要显示几列表格，以及是否要显示图片名称：

最终效果：