请教大哥们WORD用VBA批量插入图片的问题

kongbu888

Sub 插入图片到表格()
    ' 定义变量
    Dim folderPath As String
    Dim fileName As String
    Dim fileExt As String
    Dim i As Long
    Dim pic As InlineShape
    Dim table As table
    Dim rowCount As Integer
    Dim colCount As Integer
    Dim currentRow As Integer
    Dim currentCol As Integer
    Dim docPath As String

    ' 设置图片所在的文件夹路径
    folderPath = "D:\123\"

    ' 确保路径以反斜杠结束
    If Right(folderPath, 1) <> "\" Then
        folderPath = folderPath & "\"
    End If

    ' 创建或获取当前文档中的表格
    Set table = ActiveDocument.Tables.Add(Range:=Selection.Range, NumRows:=5, NumColumns:=3)

    ' 设置当前行为0，列也为0
    currentRow = 1
    currentCol = 1

    ' 打开文件夹以获取文件列表
    fileName = Dir(folderPath & "*.jpg")

    ' 遍历文件夹中的所有.jpg文件
    Do While fileName <> ""
        ' 构建文件的完整路径
        fileExt = Right(fileName, 4)

        ' 检查文件扩展名是否为图片格式
        If fileExt = ".jpg" Or fileExt = ".png" Or fileExt = ".bmp" Then
            ' 在表格的指定单元格中插入图片
            Set pic = table.Cell(currentRow, currentCol).Range.InlineShapes.AddPicture( _
                fileName:=folderPath & fileName, LinkToFile:=False, SaveWithDocument:=True, _
                Range:=table.Cell(currentRow, currentCol).Range)
        End If

        ' 更新当前列，如果到达最后一列，则移动到下一行的第一列
        currentCol = currentCol + 1

        ' 如果当前列更新后超过了表格的列数，移动到下一行的第一列
        If currentCol > table.Columns.Count Then
            currentCol = 1
            currentRow = currentRow + 1
        End If

        ' 如果当前行更新后超过了表格的行数，则退出循环
        If currentRow > table.Rows.Count Then
            Exit Do
        End If

    ' 获取下一个文件名
    fileName = Dir
Loop

' 清除文件名列表
fileName = ""
End Sub

这是AI生成的代码，修改了好多次，只能到这个效果，请问一下大哥们，这里在咋么修改呀，要求就是，一张A4纸插入15副图片，不改变表格大小，适当缩小图片，用EXCEL写人可以插入成功但打印出来效果不好，

3190496160

用excel的vba在word表格中插入图片的帖子回过的太多了，自己搜搜看看呗
没有相应的图片，没法测试代码正确与否，只能这么跟你说

kongbu888

3190496160 发表于 2024-4-5 12:36
用excel的vba在word表格中插入图片的帖子回过的太多了，自己搜搜看看呗
没有相应的图片，没法测试代码正确 ...

大哥，图片我上传了一张，其他的大小都一样的，麻烦您看一下

闻启学

亲 这个不用VBA都行  邮件合并

gwjkkkkk

Option Explicit
Sub test()
    Dim Items As FileDialogSelectedItems, vNum As Double
    Dim strPath$, i&, Pic As InlineShape
   
    With Application.FileDialog(1)
        With .Filters
            .Clear
            .Add "PIC Files", "*.png,*.jpg,*.gif"
        End With
        .Title = "请选择一个图片文件"
        .AllowMultiSelect = False
        .InitialFileName = strPath
        If .Show Then Set Items = .SelectedItems Else Exit Sub
    End With
   
    With ActiveDocument
        For Each Pic In .InlineShapes
           Pic.Delete
        Next
        With .Tables(1)
        For i = 1 To .Range.Cells.Count
            With .Range.Cells(i)
                vNum = .Height
                .Select
                With Selection
                    .Collapse
                    With .InlineShapes.AddPicture(Items(1), , True)
                        .LockAspectRatio = True
                        .Height = vNum - 13
                        .Select
                        Selection.Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
                    End With
                End With
            End With
        Next i
        End With
    End With
End Sub

gwjkkkkk

请参考附件。。。

kongbu888

gwjkkkkk 发表于 2024-4-5 19:50
Option Explicit
Sub test()
    Dim Items As FileDialogSelectedItems, vNum As Double

谢谢大哥，这个代码可以运行，可能是我没说清楚，我一次想插入很多张，尺寸大小一样，但内容不同的图片

kongbu888

闻启学 发表于 2024-4-5 18:35
亲 这个不用VBA都行  邮件合并

大哥，请问，用邮件合并就可以插入很多张不同的图片吗？？？

gwjkkkkk

kongbu888 发表于 2024-4-5 22:37
谢谢大哥，这个代码可以运行，可能是我没说清楚，我一次想插入很多张，尺寸大小一样，但内容不同的图片

简单修改一下，你可以多选一下，按选择插入。。。

kongbu888

gwjkkkkk 发表于 2024-4-5 22:55
简单修改一下，你可以多选一下，按选择插入。。。

谢谢大哥~~~~