Word如何使用VBA代码批量将选中的文件夹中的照片及子文件夹的照片插入word表格中

louliu7

请教大神，Word如何使用VBA代码批量将选中的文件夹中的照片及子文件夹的照片插入word的表格中，并且在插入时可以选择在图片行下面插入空白行还是插入空白行，并在空白行里面插入上面图片的名字。
下面是我目前的代码，可以实现将所选中的照片插入word表格中，但是无法插入选中文件夹及子文件夹的照片，无法选择是否在照片下面插入一行并插入照片名字名

Sub 插入图片()
Dim CL, i&, Fn, ST&, RL&, SI
Dim W As Double, WW As Double
If Selection.Information(wdWithInTable) = True Then '在表格中则退出
    MsgBox "请选择非表格区域.", vbCritical + vbOKOnly, "警告..."
    Exit Sub
End If

CL = InputBox("请输入插入图片的列数.", "输入...")
If Not VBA.IsNumeric(CL) Then
    If CL = "" Then Exit Sub
    MsgBox "必须输入数字.", vbCritical + vbOKOnly, "警告..."
    Exit Sub
End If

If Selection.Start = ActiveDocument.Content.End - 1 Then '如光标在文末
    Selection.TypeParagraph '在文末添加一空段
Else
    Selection.EndKey
End If

With ActiveDocument.PageSetup
    W = (.PageWidth - .LeftMargin - .RightMargin) / CL
End With

Application.ScreenUpdating = False
With Application.FileDialog(msoFileDialogFilePicker)    '选择文件
    .InitialView = msoFileDialogViewList
    .Filters.Add "图片文件", "*.jpg,*.png,*.bmp", 1
    .AllowMultiSelect = True
    If .Show = -1 Then
    ST = .SelectedItems.count
            RL = ((ST \ CL) + Sgn(ST Mod CL)) * 2
     
        Set SI = .SelectedItems
        Dim R&, C&, k&
        With ActiveDocument.Tables.Add(Selection.Range, RL, CL, 1, 1)    '新建表格
            .Borders.Enable = True
                For Each Fn In SI
                    k = k + 1
                    R = (k - 1) \ CL + 1    '现在行
                    C = (k - 1) Mod CL + 1      '现在列
                       With .cell(R * 2 - 1, C).Range.InlineShapes.AddPicture(FileName:=Fn, SaveWithDocument:=True)
                        WW = .Width
                        .Width = W
                        .Height = .Height * (W / WW)
                    End With
                    .cell(R * 2, C).Range.Text = Basename(Fn)
                Next Fn
        End With
    End If
End With
Selection.EndKey
Application.ScreenUpdating = True
MsgBox "ok", vbInformation + vbOKOnly, "提示..."

Myheigth = 6.14  '设置高度
    Mywidth = 8.18   '设置宽度
    On Error Resume Next
    For Each iShape In ActiveDocument.InlineShapes
    iShape.LockAspectRatio = msoFlase
    iShape.Height = 28.345 * Myheigth
    iShape.Width = 28.345 * Mywidth
        
    With iShape
    .Range.ParagraphFormat.Reset
    .Range.ParagraphFormat.Alignment = wdAlignParagraphCenter '居中
    .LockAspectRatio = msoTrue
    End With
    Next

  Dim tbl As table
    For Each tbl In ActiveDocument.Tables
        tbl.PreferredWidthType = wdPreferredWidthPoints
        tbl.PreferredWidth = CentimetersToPoints(17.5)
    Next tbl

End Sub

zhanglei1371

按目录结构生成图片_哔哩哔哩_bilibili  
https://www.bilibili.com/video/BV1Us42137Xi/?pop_share=1

闻启学

亲  上转附件看看  

louliu7

闻启学 发表于 2024-4-18 21:10
亲  上转附件看看

您好，附件是需要插入的照片（文件夹数量和照片数量每次不一样）和希望插入后的效果，感谢大神帮忙

louliu7

闻启学 发表于 2024-4-18 21:10
亲  上转附件看看

您好，附件是需要插入的照片（文件夹数量和照片数量每次不一样）和希望插入后的效果，感谢大神帮忙

louliu7

闻启学 发表于 2024-4-18 21:10
亲  上转附件看看

您好，附件是需要插入的照片（文件夹数量和照片数量每次不一样）和希望插入后的效果，感谢大神帮忙，如果很麻烦的话，可以付费

zhanglei1371

louliu7 发表于 2024-5-17 12:30
您好，附件是需要插入的照片（文件夹数量和照片数量每次不一样）和希望插入后的效果，感谢大神帮忙，如果 ...

确实很麻烦。需要递归。回头加到插件里去。

gwjkkkkk

zhanglei1371 发表于 2024-5-24 19:29
确实很麻烦。需要递归。回头加到插件里去。

因为固定层级，可以不需要递归，但写起肯定是很麻烦的。。。

gwjkkkkk

Option Explicit
Option Compare Text
Sub TEST6()
    Dim ar(), br(), i&, j&, r&, k&, m&, fso As Object, n$, dWeight As Double
    Dim strPath$, strPath1, strPath2$, ff, f, picName, iRowCount&, pic As Picture
   
    n = InputBox("请选择随机行数", Title:="提示", Default:=2)
    If Val(n) = 0 Then Exit Sub
   
    strPath = ThisDocument.Path & "\产品照片\"
    If Dir(strPath, vbDirectory) = "" Then Exit Sub
   
    Application.ScreenUpdating = False
   
    Set fso = CreateObject("Scripting.FileSystemObject")
    For Each ff In fso.GetFolder(strPath).SubFolders
        r = r + 1
        iRowCount = iRowCount + 1
        ReDim Preserve ar(1 To 2, 1 To r)
        ar(1, r) = ff.Name
        Set ar(2, r) = CreateObject("Scripting.Dictionary")
        
        strPath1 = strPath & ff.Name & "\"
        For Each f In fso.GetFolder(strPath1).SubFolders
            iRowCount = iRowCount + 1
            Set ar(2, r)(f.Name) = CreateObject("Scripting.Dictionary")
            
            strPath2 = strPath1 & f.Name & "\"
            For Each picName In fso.GetFolder(strPath2).Files
                If picName.Name Like "*.jpg" Then
                    ar(2, r)(f.Name)(picName.Name) = picName.Path
                End If
                ReDim br(1 To 2, 1 To ar(2, r)(f.Name).Count)
                For j = 1 To UBound(br, 2)
                    br(1, j) = ar(2, r)(f.Name).Items()(j - 1)
                    br(2, j) = Split(ar(2, r)(f.Name).Keys()(j - 1), ".jpg")(0)
                Next j
            Next picName
            
            br = transArrToRow(br, CLng(n))
            ar(2, r)(f.Name) = br
            iRowCount = iRowCount + UBound(br)
        Next f
    Next ff
   
    With ActiveDocument
        With .PageSetup
            dWeight = (.PageWidth - .LeftMargin - .RightMargin) / n
        End With
        .Content.Delete
        With .Tables.Add(Range:=.Range(0), NumRows:=iRowCount, NumColumns:=n, DefaultTableBehavior:=wdWord9TableBehavior)
            r = 0
            For j = 1 To UBound(ar, 2)
                r = r + 1
                With .Cell(r, 1).Range
                    .Text = ar(1, j)
                    .Font.Bold = True
                    .Font.Size = 14
                End With
                .Rows(r).Cells.Merge
                For k = 0 To ar(2, j).Count - 1
                    r = r + 1
                    With .Cell(r, 1).Range
                        .Text = ar(2, j).Keys()(k)
                        .Font.Bold = True
                        .Font.Size = 12
                    End With
                    .Rows(r).Cells.Merge
                    br = ar(2, j).Items()(k)
                    For i = 1 To UBound(br)
                        r = r + 1
                        For m = 1 To UBound(br, 2)
                            If Len(br(i, m)) Then
                                If i Mod 2 = 1 Then
                                    With .Cell(r, m).Range
                                        With .InlineShapes.AddPicture(br(i, m), , True)
                                            .LockAspectRatio = True
                                            .Width = dWeight
                                        End With
                                    End With
                                Else
                                    .Cell(r, m).Range.Text = br(i, m)
                                End If
                            End If
                        Next m
                    Next i
                Next k
            Next j
        End With
    End With
   
    Application.ScreenUpdating = True
    Beep
End Sub

Function transArrToRow(ar, iCutNum&, Optional iLeftCol& = 1 _
    , Optional iRightCol& = 0) As Variant()
   
    Dim br(), n&, i&, j&, k&, iPosRow&, iPosCol&, iEnd&
   
    If iRightCol = 0 Then iRightCol = UBound(ar, 2)
   
    n = -(Int(-(iRightCol - iLeftCol + 1) / iCutNum))
    ReDim br(1 To UBound(ar) * n, 1 To iCutNum)
    For i = 1 To n
        iPosRow = (i - 1) * UBound(ar)
        iPosCol = (i - 1) * iCutNum + iLeftCol
        iEnd = IIf(iPosCol + iCutNum - 1 > iRightCol, _
        (iRightCol - iLeftCol + 1) Mod iCutNum, iCutNum)
        For j = 1 To UBound(ar)
            For k = 1 To iEnd
                br(iPosRow + j, k) = ar(j, iPosCol - 1 + k)
            Next k
        Next j
    Next i
   
    transArrToRow = br
End Function

gwjkkkkk

图片文件太大不上传了，将图片目录放在主文档的同一目录下。。。