如何根据文件夹下的照片批量插入到报告模板excelvba

wang_jg

pcd文件夹下面的图片，批量插入到“数据验收报告模板”里面（报告模板中黑体字部分不动）

分为三类：高速、地库、城区
需excel VBA代码实现

liulang0808

https://club.excelhome.net/threa ... tml?_dsign=15791c27
插入图片的案例，楼主看看是否有用吧

chengyunpan

文件下载不了

wang_jg

chengyunpan 发表于 2024-3-24 14:13
文件下载不了

压缩包全部下载下来，然后解压。论坛单个压缩包大小由限制

gwjkkkkk

Option Explicit
Sub test()
    Dim ar(), br, i&, j&, r&, strPath$, strFileName$, strSaveName$
   
    strPath = ThisDocument.Path & "\"
    With Application.FileDialog(4)
        .InitialFileName = strPath
        If .Show Then strPath = .SelectedItems(1) & "\" Else Exit Sub
    End With
   
    strFileName = Dir(strPath & "*.png")
    Do Until strFileName = ""
        r = r + 1
        ReDim Preserve ar(1 To 2, 1 To r)
        ar(1, r) = strFileName: ar(2, r) = strPath & strFileName
        strFileName = Dir
    Loop
    If r = 0 Then MsgBox "未发现图片文件,请重新选择": Exit Sub
   
    strFileName = ThisDocument.Path & "\" & "数据验收报告模板.docx"
    If Dir(strFileName) = "" Then MsgBox "模板文件不存在，请检查！", vbExclamation: Exit Sub
   
    Application.ScreenUpdating = False
   
    br = Array("地库场景：", "城区场景：", "高速场景：")
    With Documents.Open(strFileName)
        strSaveName = ThisDocument.Path & "\" & "数据验收报告"
        For i = 0 To UBound(br)
            With .Content.Find
                .Execute FindText:=br(i), Forward:=True
                If .Found Then
                     .Parent.Select
                     With Selection
                         .Collapse 0: .InsertBreak (6)
                         For j = 1 To UBound(ar, 2)
                             If InStr(ar(1, j), Left(br(i), 2)) Then
                                 .InlineShapes.AddPicture ar(2, j), , True
                             End If
                         Next j
                    End With
                End If
            End With
        Next i
        .SaveAs strSaveName
        .Close
    End With
    Application.ScreenUpdating = True
End Sub

gwjkkkkk

文件解压后，请自行选择图片目录，请参考。。。

wang_jg

gwjkkkkk 发表于 2024-3-24 19:39
文件解压后，请自行选择图片目录，请参考。。。

1、最好能用excelvba程序实现。
2、pic文件夹目前放了地库、高速、城区3个分类的数据；后面实际可能有2个分类，或者1个分类，或者0个分类（pic下面没有图片），或者有4个分类，程序能自动识别。程序根据pic文件夹下面的图片的命名智能的输入到word里面。如果pic下面有“地库”字样的图片，word报告里面就输入“地库场景”，并插入地库字样的图片。如果pic下面没有如何图片，程序不用操作。

wang_jg

gwjkkkkk 发表于 2024-3-24 19:23
Option Explicit
Sub test()
    Dim ar(), br, i&, j&, r&, strPath$, strFileName$, strSaveName$

刚才代码运行了，谢谢！

gwjkkkkk

wang_jg 发表于 2024-3-24 21:19
1、最好能用excelvba程序实现。
2、pic文件夹目前放了地库、高速、城区3个分类的数据；后面实际可能有2 ...

Option Explicit
Sub TEST()
    Dim wdApp As Word.Application, strFileName$, strPath$
    Dim ar, br, i&, j&, dic As Object, strName$, vKey

    strPath = ThisWorkbook.Path & "\"
    With Application.FileDialog(4)
        .InitialFileName = strPath
        If .Show Then strPath = .SelectedItems(1) & "\" Else Exit Sub
    End With

    Set dic = CreateObject("Scripting.Dictionary")
    strFileName = Dir(strPath & "*.png")
    Do Until strFileName = ""
        strName = Left(strFileName, 2)
        dic(strName) = dic(strName) & "|" & strPath & strFileName
        strFileName = Dir
    Loop

    If dic.Count = 0 Then MsgBox "没有符合的照片！": Exit Sub

    Application.ScreenUpdating = False
    On Error Resume Next
    Set wdApp = GetObject(, "Word.Application")
    If Err <> 0 Then
        Set wdApp = New Word.Application
    End If

    strPath = ThisWorkbook.Path & "\"
    With wdApp.Documents.Add
        strName = strPath & "数据验收报告"
        With wdApp.Selection
            .InsertBreak (6)
            .InsertAfter "数据验收报告"
            With .Font
                .Name = "微软雅黑"
                .Bold = True
                .Size = 26
            End With
            .Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
            .InsertAfter Chr(13)
            .Collapse 0
            .InsertAfter "标注结果截图实例："
            .Font.Size = 11
            .Range.ParagraphFormat.Alignment = wdAlignParagraphLeft
            .Collapse 0
            For Each vKey In dic.keys
                .Collapse 0
                .InsertAfter Chr(13)
                .InsertAfter vKey & "场景："
                With .Font
                    .ColorIndex = wdRed
                    .Size = 11
                End With
                .Collapse 0
                br = Split(dic(vKey), "|")
                For j = 0 To UBound(br)
                    .InlineShapes.AddPicture br(j), , True
                Next j
            Next
        End With
        .SaveAs strName
        .Close
    End With

    If Err <> 0 Then wdApp.Quit
    Set wdApp = Nothing
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

按照你逻辑重写了一遍