根据Excel数据、图片名称批量生成Word文件

lommou

求大佬帮忙，Word文件写VBA程序，将Excel数据信息调入Word文件表格中，并根据混接点编号批量插入照片。

蜀中草莽

不用代码  也能实现   https://www.bilibili.com/video/BV1vmUwYbEN2/?spm_id_from=333.999.0.0&vd_source=e584340e59b74ca5d8c738b00879e299

3190496160

这个问题，太繁琐，工作量不小，先留个记号吧

lommou

3190496160 发表于 2024-11-21 09:26
这个问题，太繁琐，工作量不小，先留个记号吧

小白，等级太低，还不符合加好友条件

3190496160

这个效果？？

lommou

3190496160 发表于 2024-11-21 16:39
这个效果？？

是的，不过当一条路有多个混接点时，只在第一个混接点处显示道路名称，且道路名称选择标题9的格式，图片不能裁剪要依比例缩放至7厘米

lommou

3190496160 发表于 2024-11-21 16:39
这个效果？？

Sub 根据Excel混接点数据批量生成Word文件()
    Dim wdApp As Object
    Dim wdDoc As Object
    Dim wdShape As Object
    Dim f As String
    Dim arr As Variant
    Dim j As Long
    Dim maxSize As Double
    Dim imgPathPrefix As String
    Dim imgPath1 As String, imgPath2 As String, imgPath3 As String
    Dim shp As Object ' 用于遍历Word文档中的形状
   
    ' 创建 Word 应用程序对象
    Set wdApp = CreateObject("WORD.APPLICATION")
    wdApp.Visible = True ' 如果需要看到 Word 应用程序，可以设置为 True
   
    ' 设置模板文件路径
    f = ThisWorkbook.Path & "\混接点调查表-模板.docx"
    ' 读取 Excel 工作表数据
    arr = ThisWorkbook.Sheets(1).UsedRange.Value
   
    ' 禁用 Excel 屏幕更新以提高性能
    Application.ScreenUpdating = False
   
    ' 打开 Word 模板文档
    Set wdDoc = wdApp.Documents.Open(f)
    maxSize = 7 * 28.35
   
    ' 遍历 Excel 数据并生成 Word 文件
    For j = 2 To UBound(arr, 1)
        If Len(Trim(arr(j, 2))) > 0 Then ' 检查数据是否为空，并使用 Trim 去除空格
            ' 删除Word文档中的旧图片（假设图片是内联的，且都在表格中）
            For Each shp In wdDoc.Tables(1).Range.InlineShapes
                shp.Select
                shp.Delete ' 注意：这将删除所有内联形状，不仅仅是图片。需要更精确的逻辑来只删除图片。
            Next shp
            imgPathPrefix = ThisWorkbook.Path & "\" & arr(j, 4) & "-"
            imgPath1 = imgPathPrefix & "1.jpg"
            imgPath2 = imgPathPrefix & "2.jpg"
            imgPath3 = imgPathPrefix & "3.jpg"
            
            ' 检查图片文件是否存在（可选，但推荐）
            ' 这里添加检查文件存在性的代码
            If Dir(imgPath1) <> "" And Dir(imgPath2) <> "" And Dir(imgPath3) <> "" Then
                With wdDoc.Tables(1)
                    .Cell(2, 2).Range.Text = arr(j, 2)
                    .Cell(2, 4).Range.Text = arr(j, 3)
                    .Cell(3, 2).Range.Text = arr(j, 4)
                    .Cell(3, 4).Range.Text = arr(j, 5)
                    .Cell(4, 2).Range.Text = arr(j, 6)
                    .Cell(5, 2).Range.Text = arr(j, 13)
                    .Cell(6, 2).Range.Text = arr(j, 14)
                    .Cell(7, 2).Range.Text = arr(j, 15)
                    .Cell(8, 2).Range.Text = arr(j, 16)
                    
                    ' 插入并调整图片大小（注意：InlineShape没有LockAspectRatio属性）
                    Set wdShape = .Cell(5, 3).Range.InlineShapes.AddPicture(imgPath1)
                    If wdShape.Height > maxSize Or wdShape.Width > maxSize Then
                        If wdShape.Height > wdShape.Width Then
                            wdShape.Height = maxSize
                        Else
                            wdShape.Width = maxSize
                        End If
                    End If
                                        ' 不需要再次设置Height，因为Width已经设置了，且InlineShape通常保持比例（如果Word设置允许）
                    Set wdShape = .Cell(11, 1).Range.InlineShapes.AddPicture(imgPath2)
                    If wdShape.Height > maxSize Or wdShape.Width > maxSize Then
                        If wdShape.Height > wdShape.Width Then
                            wdShape.Height = maxSize
                        Else
                            wdShape.Width = maxSize
                        End If
                    End If
                    Set wdShape = .Cell(11, 2).Range.InlineShapes.AddPicture(imgPath3)
                    If wdShape.Height > maxSize Or wdShape.Width > maxSize Then
                        If wdShape.Height > wdShape.Width Then
                            wdShape.Height = maxSize
                        Else
                            wdShape.Width = maxSize
                        End If
                    End If
                End With
               
                ' 保存 Word 文档
                wdDoc.SaveAs2 Filename:=ThisWorkbook.Path & "\" & arr(j, 2) & "-" & arr(j, 4) & ".docx"
            Else
                With wdDoc.Tables(1)
                    .Cell(2, 2).Range.Text = arr(j, 2)
                    .Cell(2, 4).Range.Text = arr(j, 3)
                    .Cell(3, 2).Range.Text = arr(j, 4)
                    .Cell(3, 4).Range.Text = arr(j, 5)
                    .Cell(4, 2).Range.Text = arr(j, 6)
                    .Cell(5, 2).Range.Text = arr(j, 13)
                    .Cell(6, 2).Range.Text = arr(j, 14)
                    .Cell(7, 2).Range.Text = arr(j, 15)
                    .Cell(8, 2).Range.Text = arr(j, 16)
                End With
                wdDoc.SaveAs2 Filename:=ThisWorkbook.Path & "\" & arr(j, 2) & "-" & arr(j, 4) & ".docx"
                'MsgBox "图片文件不存在，无法生成Word文档：" & vbCrLf & imgPath1 & ", " & imgPath2 & ", " & imgPath3, vbExclamation
            End If
        End If
    Next j
   
    ' 关闭 Word 文档（因为我们已经保存了每个副本，所以不需要再次保存）
    wdDoc.Close False
   
    ' 退出 Word 应用程序（如果不再需要）
    wdApp.Quit
   
    ' 重新启用 Excel 屏幕更新
    Application.ScreenUpdating = True
   
    ' 清理对象变量
    Set wdDoc = Nothing
    Set wdApp = Nothing
End Sub

不能设置道路名称标题，不能生成在同一个文件，能不能增加一个功能，将缺少图片的混接点名称和道路名称以Excel文件形式输出

3190496160

lommou 发表于 2024-11-22 09:51
Sub 根据Excel混接点数据批量生成Word文件()
    Dim wdApp As Object
    Dim wdDoc As Object

加我v具体沟通吧