批量插入图片到word或者excel中

wuqing960412

约定的童话 发表于 2021-3-30 21:50
新模板没用，还是用之前的模板做的效果，看下https://wwx.lanzoui.com/i2EIqnhjadc

大佬，代码能分享一下吗，万分感谢

补充内容 (2021-4-7 15:31):
能分享分享嘛，目前也只有你的合适，万分感谢

z9bhd

wuqing960412 发表于 2021-3-29 20:56
麻烦各位大佬瞅瞅，谢谢

试试看，笨招
Sub 提取照片()
    Dim filesys As Object, drv As Object, fd As FileDialog, t As Table
    Dim wd As Document, wd1 As Document, w$, s$, m$, n%, i%, a%, a1%, b%, b1%, d%, h%
    Application.ScreenUpdating = False
    Set filesys = CreateObject("scripting.filesystemobject")
    Set fd = Application.FileDialog(4)
    fd.AllowMultiSelect = True
    fd.Show               '请选择子文件夹的上一级文件夹，获得父文件夹路径
    On Error Resume Next
    s = fd.InitialFileName
    For Each drv In filesys.GetFolder(s).SubFolders
        If drv.Size > 0 Then
            m = drv.Name
            n = filesys.GetFolder(s & m & "\").Files.Count
            Set wd = Documents.Add
            Selection.TypeText "七、现场照片等影像成果" & m & Chr(13)
            Selection.TypeText Chr(13)
            a = ActiveDocument.Sections.First.PageSetup.PageHeight '页高
            a1 = ActiveDocument.Sections.First.PageSetup.TopMargin '当前文档第一节所在页的顶边距
            h = (a - 2 * a1 - 70) / 28.35
            b = ActiveDocument.Sections.First.PageSetup.PageWidth '页宽
            b1 = ActiveDocument.Sections.First.PageSetup.LeftMargin '左边距
            d = (b - 2 * b1 - 10) / 28.35
            If n Mod 2 = 0 Then
                If n = 2 Then
                    Set t = wd.Tables.Add(Selection.Range, 2, 1)
                    For i = 1 To 2
                        t.Range.Cells(i).Range.InlineShapes.AddPicture s & m & "\" & m & "_" & i & ".jpg"
                        wd.InlineShapes(i).LockAspectRatio = msoFalse
                        wd.InlineShapes(i).Height = CentimetersToPoints(h / 2)
                        wd.InlineShapes(i).Width = CentimetersToPoints(d)
                    Next
                Else
                    Set t = wd.Tables.Add(Selection.Range, n / 2, 2)
                    For i = 1 To n
                        t.Range.Cells(i).Range.InlineShapes.AddPicture s & m & "\" & m & "_" & i & ".jpg"
                        wd.InlineShapes(i).LockAspectRatio = msoFalse
                        wd.InlineShapes(i).Height = CentimetersToPoints(h / 2)
                        wd.InlineShapes(i).Width = CentimetersToPoints(d / 2)
                    Next
                End If
            Else
                Set t = wd.Tables.Add(Selection.Range, (n - 1) / 2, 2)
                For i = 1 To n
                    If i <= n - 1 Then
                       t.Range.Cells(i).Range.InlineShapes.AddPicture s & m & "\" & m & "_" & i & ".jpg"
                       wd.InlineShapes(i).LockAspectRatio = msoFalse
                       wd.InlineShapes(i).Height = CentimetersToPoints(h / 2)
                       wd.InlineShapes(i).Width = CentimetersToPoints(d / 2)
                    Else
                       Selection.EndKey unit:=wdStory
                       Selection.TypeText Chr(13)
                       Selection.Range.InlineShapes.AddPicture s & m & "\" & m & "_" & i & ".jpg"
                       wd.InlineShapes(n).LockAspectRatio = msoFalse
                       wd.InlineShapes(n).Height = CentimetersToPoints(h / 2)
                       wd.InlineShapes(n).Width = CentimetersToPoints(d + 0.35)
                    End If
                Next i
            End If
        End If
        wd.SaveAs2 (s & m & ".docx")
        wd.Close
     Next drv
     Set fd = Nothing
     Set filesys = Nothing
     Application.ScreenUpdating = True
End Sub

wuqing960412

z9bhd 发表于 2021-4-6 22:24
试试看，笨招
Sub 提取照片()
    Dim filesys As Object, drv As Object, fd As FileDialog, t As Tab ...

麻烦看下，我这个是怎么回事，还有麻烦问下这个如何读取模板，根据照片生成一个个word文档

wuqing960412

z9bhd 发表于 2021-4-6 22:24
试试看，笨招
Sub 提取照片()
    Dim filesys As Object, drv As Object, fd As FileDialog, t As Tab ...

大佬。，麻烦看下这个https://wwe.lanzous.com/icCvynr71eh

z9bhd

wuqing960412 发表于 2021-4-7 15:36
麻烦看下，我这个是怎么回事，还有麻烦问下这个如何读取模板，根据照片生成一个个word文档

不用读取模板，已按你的要求设置好了，你要先打开word,新建一个文档，再把代码复制进去，点选模板所在的文件夹就可以了

z9bhd

wuqing960412 发表于 2021-4-7 15:50
大佬。，麻烦看下这个https://wwe.lanzous.com/icCvynr71eh

不是什么大佬，菜鸟一个，和你相比只是时间比较多而已，附件已下载，不一定搞的好，试试看吧

z9bhd

wuqing960412 发表于 2021-4-7 15:50
大佬。，麻烦看下这个https://wwe.lanzous.com/icCvynr71eh

你的模板没法用，参照模板要求写了个代码，测试结果基本符合你的要求，你看看，如果不行再做调整

Sub 提取照片()
    Dim filesys As Object, drv As Object, fd As FileDialog, t As Table
    Dim wd As Document, wd1 As Document, w$, s$, m$, n%, i%, a%, a1%, b%, b1%, d%, h%
    Application.ScreenUpdating = False
    Set filesys = CreateObject("scripting.filesystemobject")
    Set fd = Application.FileDialog(4)
    fd.AllowMultiSelect = True
    fd.Show
    On Error Resume Next
    s = fd.InitialFileName
    s1 = Replace(s, "照片", "结果")
    For Each drv In filesys.GetFolder(s).SubFolders
        If drv.Size > 0 Then
            m = drv.Name
            n = filesys.GetFolder(s & m & "\").Files.Count
            Set wd = Documents.Add
            With Selection
                .Font.Name = "宋体"
                .Font.Bold = True
                .Font.Size = "12"
                .Text = "七：现场照片等影像成果" & Chr(13)
                .EndKey unit:=wdStory
            End With
            If n Mod 2 = 0 Then
                If n = 2 Then
                    Set t = wd.Tables.Add(Selection.Range, 2, 1)
                    For i = 1 To 2
                        t.Range.Cells(i).Range.InlineShapes.AddPicture s & m & "\" & m & "_" & i & ".jpg"
                        wd.InlineShapes(i).LockAspectRatio = msoFalse
                        wd.InlineShapes(i).Height = CentimetersToPoints(11.11)
                        wd.InlineShapes(i).Width = CentimetersToPoints(14.62)
                    Next
                Else
                    Set t = wd.Tables.Add(Selection.Range, n / 2, 2)
                    For i = 1 To n
                        t.Range.Cells(i).Range.InlineShapes.AddPicture s & m & "\" & m & "_" & i & ".jpg"
                        wd.InlineShapes(i).LockAspectRatio = msoFalse
                        wd.InlineShapes(i).Height = CentimetersToPoints(11.11)
                        wd.InlineShapes(i).Width = CentimetersToPoints(7.23)
                    Next
                End If
            Else
                For i = 1 To n
                    If i = 1 Then
                       
                       Selection.Range.InlineShapes.AddPicture s & m & "\" & m & "_" & i & ".jpg"
                       wd.InlineShapes(i).LockAspectRatio = msoFalse
                       wd.InlineShapes(i).Height = CentimetersToPoints(11.11)
                       wd.InlineShapes(i).Width = CentimetersToPoints(14.62)
                        Selection.EndKey unit:=wdStory
                        Selection.TypeText Chr(13)
                        Selection.EndKey unit:=wdStory
                       Set t = wd.Tables.Add(Selection.Range, 1, 2)
                    Else
                       t.Range.Cells(i - 1).Range.InlineShapes.AddPicture s & m & "\" & m & "_" & i & ".jpg"
                       wd.InlineShapes(i).LockAspectRatio = msoFalse
                       wd.InlineShapes(i).Height = CentimetersToPoints(11.11)
                       wd.InlineShapes(i).Width = CentimetersToPoints(7.23)
                    End If
                Next i
            End If
        End If
        wd.SaveAs2 (s1 & m & ".docx")
        wd.Close
     Next drv
     Set fd = Nothing
     Set filesys = Nothing
     Application.ScreenUpdating = True
End Sub