word批量插入图片

540437111

我想把文件夹内的图片 都按 结果文件那样 批量插入

ming0018

先获取所有图片路径，再画表格，最后插入图片到表格中，如果有顺序要求就先排下序。

dragonthree

图片长宽比和单元格长宽比差不多吗？

3190496160

Sub word表格插入图片()
Application.ScreenUpdating = False
Dim oFso
Set oFso = CreateObject("Scripting.FileSystemObject")
Dim i%, arr, myPath$, wdApp, wdD
myPath = ThisWorkbook.Path & "\"
f = Dir(myPath & "归档\*.jpg")
Do While f <> ""
    m = m + 1
f = Dir
Loop
If Int(m / 4) = m / 4 Then
    hs = m / 4
Else
    hs = Int(m / 4) + 1
End If
f = Dir(myPath & "归档\*.jpg")
rr = Array(1, 2, 3, 4)
Set wdApp = CreateObject("word.application")
wdApp.Visible = True
FileCopy myPath & "模板.docx", myPath & "插入图片.docx"
Set wdD = wdApp.Documents.Open(myPath & "插入图片.docx")
With wdApp
    .Selection.HomeKey unit:=6 'wdStory '光标置于文件首
    .Selection.TypeParagraph '''光标下移一行
    .ActiveDocument.Tables.Add Range:=.Selection.Range, NumRows:=hs, NumColumns:=4 '插入表格
    Set wdBG = wdApp.ActiveDocument.Tables(1) '(1) '创建表格对象
    With wdBG '
        If .Style <> "网格型" Then
            .Style = "网格型"
        End If
        .Range.Font.Size = 72 '字号
        x = 1
        Do While f <> ""
            y = y + 1
            If y > 4 Then
                y = 1
                x = x + 1
            Else
                y = y
            End If
            tp = myPath & "归档\" & f
            .Cell(x, y).Range.InlineShapes.AddPicture Filename:=tp, LinkToFile:=False, SaveWithDocument:=True '直接插入
        f = Dir
        Loop
    End With
End With
wdD.Save
wdD.Close True
wdApp.Quit
Set wdD = Nothing
Set wdApp = Nothing
Application.ScreenUpdating = False
MsgBox "ok!"
End Sub

3190496160

新建文件夹.rar (1.61 MB, 下载次数: 30)

2024-7-10 09:31 上传

点击文件名下载附件

gwjkkkkk

word宏，请参考，图片1.png可预先处理一下。。。
Option Explicit
Option Compare Text
Sub test()
    Dim br$(), i&, r&, n&, iPosRow&, iPosCol&, wdApp As Word.Application
    Dim strFileName$, strPath$, strPicPath$, strPicName$, pic As InlineShape
   

    strPath = ThisDocument.Path & "\"
    strPicPath = strPath & "归档\"
   
    strFileName = Dir(strPicPath & "*.jpg")
    Do Until strFileName = ""
        r = r + 1
        ReDim Preserve br(1 To r)
        br(r) = strPicPath & strFileName
        strFileName = Dir
    Loop

    If r = 0 Then Exit Sub
   
    Application.ScreenUpdating = False

    n = -Int(-UBound(br) / 4)
    With Documents.Add
        With .PageSetup
            .LeftMargin = .LeftMargin - 20
            .RightMargin = .RightMargin - 20
        End With
        strPicName = strPath & "图片1.png"
        With .Tables.Add(Range:=Selection.Range, NumRows:=n, NumColumns:=4, DefaultTableBehavior:=8)
            .Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
            .Range.Cells.VerticalAlignment = wdCellAlignVerticalCenter
            With .Borders
                .InsideLineStyle = wdLineStyleNone
                .OutsideLineStyle = wdLineStyleNone
            End With
            For i = 1 To UBound(br)
                iPosRow = -Int(-i / 4): iPosCol = IIf(i Mod 4 = 0, 4, i Mod 4)
                Set pic = .Cell(iPosRow, iPosCol).Range.InlineShapes.AddPicture(strPicName)
                With pic
                    .LockAspectRatio = True
                    .Height = 65
                End With
                Set pic = .Cell(iPosRow, iPosCol).Range.InlineShapes.AddPicture(br(i))
               With pic
                   .LockAspectRatio = True
                   .Height = 65
               End With
            Next i
        End With
        .SaveAs2 strPath & "结果": .Close
    End With
   
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

请参考附件。。。

65861954

邮件合并功能也可以完成的吧！