使用宏批量插入图片到Word表格

使用宏批量插入图片到Word表格

创建宏，word 视图-》宏》查看宏》输入名称》创建

 宏代码如下：

Sub imgTbl()
    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 & "\*.bmp")
    Do While picName <> "" 'Do While循环
        i = i + 1
        imgPath = PathSht + "\" + picName
        picName = Dir    ' 查找下一个图片
        ReDim Preserve imgPaths(1 To i)
        imgPaths(i) = imgPath
    Loop
    
    imgNum = UBound(imgPaths) + 1
    
    Dim value '弹出输入框，输入列数，默认10，会自动计算行数
    value = InputBox("请输入表格列数", "表格列数", "10")
    Debug.Print value
    
    tbl_columnNum = value
    tbl_rowNum = Int(imgNum / tbl_columnNum) + 1
    
    '//开始新建表格
    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.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 = wdAlignParagraphCenter '文字水平居中
    tbl.Range.Font.Size = 6

    
        
    '//开始插入图片
    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, ".")
            'tbl.Cell(i, j).Range.Text = nrr(0) '单元格文字图片名称不带后缀
            'tbl.Cell(i, j).Range.Text = "OK"
            tbl.Cell(i, j).Range.Select  '选择当前单元格
            Dim shp As InlineShape
            Set shp = Selection.Range.InlineShapes.AddPicture(FileName:=imgPath) '插入图片
            
            tbl.Cell(i, j).Range.Select  '选择当前单元格 '选中该单元格，为了下一步光标定位到单元格内部
            Selection.EndKey wdLine
            Selection.TypeText Chr(10) & nrr(0)   '单元格文字图片名称不带后缀
        Next
    Next
     
    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

新建窗体：

 点击按钮执行宏，代码：

Private Sub CommandButton1_Click()
    Application.Run MacroName:="imgTbl"
End Sub

Word打开显示窗体，代码：

Private Sub Document_Open()
    UserForm1.Show  '显示用户窗体
End Sub

执行效果：