Word插入标题+图片

Word插入三张图片为一组，分别插入分页符

Sub GenerateDocumentLayout()
    Dim titlePath As String
    Dim payPath As String
    Dim accountPath As String
    Dim invoicePath As String
    Dim titleArray() As String
    Dim i As Long, groupCount As Long
    Dim imgPath As String
    Dim fso As Object, titleFile As Object
    Dim imgHeight As Single
    Dim docContentEnd As Long
    Dim j As Integer
    Dim invoiceFound As Boolean
    Dim titleCount As Long
    
    ' 设置图片高度为20厘米（转换为磅）
    imgHeight = CentimetersToPoints(20)
    
    ' 设置文件路径（请根据实际路径修改）
    titlePath = "C:\标题.txt"    ' 标题文件路径
    payPath = "C:\支付凭证\"      ' 支付凭证图片文件夹
    accountPath = "C:\记账凭证\"  ' 记账凭证图片文件夹
    invoicePath = "C:\发票\"      ' 发票图片文件夹
    
    ' 读取标题文件
    Set fso = CreateObject("Scripting.FileSystemObject")
    If Not fso.FileExists(titlePath) Then
        MsgBox "标题文件未找到：" & titlePath, vbCritical
        Exit Sub
    End If
    
    Set titleFile = fso.OpenTextFile(titlePath)
    titleArray = Split(titleFile.ReadAll, vbCrLf)
    titleFile.Close
    
    ' 获取实际标题数量
    titleCount = UBound(titleArray) + 1
    
    Application.ScreenUpdating = False
    
    ' 记录文档原始结束位置（用于检查是否为空文档）
    docContentEnd = ActiveDocument.Content.End
    
    ' 移动到文档末尾开始插入
    Selection.EndKey Unit:=wdStory
    
    ' 如果文档非空，则从新页开始
    If ActiveDocument.Content.End > docContentEnd Then
        InsertPageBreak
    End If
    
    ' 循环处理每组内容
    For i = 1 To titleCount  ' 从1开始计数确保序号匹配
        groupCount = i
        Dim currentPage As Long
        
        ' 记录当前页码（用于检查分页情况）
        currentPage = Selection.Information(wdActiveEndPageNumber)
        
        ' 第一页：标题 + 支付凭证
        Selection.Style = ActiveDocument.Styles("标题 1")
        Selection.TypeText titleArray(i - 1)  ' 数组索引从0开始
        Selection.TypeParagraph
        Selection.TypeParagraph
        
        ' 插入支付凭证图片并设置高度（锁定纵横比）
        imgPath = FindImage(payPath, "凭证" & groupCount)
        If imgPath <> "" Then
            InsertImage imgPath, imgHeight
        Else
            ' 添加缺失图片提示
            Selection.TypeText "（缺失支付凭证" & groupCount & "）"
            Selection.TypeParagraph
        End If
        
        ' 检查是否在同一页（标题和图片在同一页）
        If Selection.Information(wdActiveEndPageNumber) > currentPage Then
            ' 如果图片导致分页，将标题复制到新页
            Selection.MoveUp Unit:=wdLine, Count:=1
            Selection.MoveUp Unit:=wdLine, Count:=1, Extend:=wdExtend
            Selection.Copy
            InsertPageBreak
            Selection.Paste
            Selection.TypeParagraph
            Selection.TypeParagraph
        End If
        
        ' 添加分页符
        InsertPageBreak
        
        ' 第二页：记账凭证
        imgPath = FindImage(accountPath, "记账凭证" & groupCount)
        If imgPath <> "" Then
            InsertImage imgPath, imgHeight
        Else
            ' 添加缺失图片提示
            Selection.TypeText "（缺失记账凭证" & groupCount & "）"
            Selection.TypeParagraph
        End If
        
        ' 添加分页符
        InsertPageBreak
        
        ' 第三部分：发票（可能有多张）
        j = 1
        invoiceFound = False
        
        Do
            ' 尝试查找发票图片（支持格式：发票n 或 发票n-1, 发票n-2 等）
            If j = 1 Then
                ' 先尝试查找不带后缀的发票（如：发票1）
                imgPath = FindImage(invoicePath, "发票" & groupCount)
                If imgPath = "" Then
                    ' 再尝试查找带-1后缀的发票（如：发票1-1）
                    imgPath = FindImage(invoicePath, "发票" & groupCount & "-1")
                End If
            Else
                ' 查找带编号的发票（如：发票1-2, 发票1-3）
                imgPath = FindImage(invoicePath, "发票" & groupCount & "-" & j)
            End If
            
            If imgPath <> "" Then
                ' 插入发票图片
                InsertImage imgPath, imgHeight
                invoiceFound = True
                
                ' 检查是否有更多发票
                j = j + 1
                If FindImage(invoicePath, "发票" & groupCount & "-" & j) <> "" Then
                    ' 还有更多发票，添加分页符
                    InsertPageBreak
                Else
                    ' 没有更多发票，退出循环
                    Exit Do
                End If
            Else
                ' 没有找到发票，退出循环
                Exit Do
            End If
        Loop
        
        ' 如果一组中没有任何发票，添加提示
        If Not invoiceFound Then
            Selection.TypeText "（缺失发票" & groupCount & "）"
            Selection.TypeParagraph
        End If
        
        ' 如果不是最后一组，添加分页符
        If i < titleCount Then
            InsertPageBreak
        End If
    Next i
    
    Application.ScreenUpdating = True
    MsgBox "文档生成完成！共创建 " & titleCount & " 组内容", vbInformation
End Sub

Function FindImage(folderPath As String, baseName As String) As String
    Dim fso As Object
    Dim file As Object
    Dim extensions As Variant
    Dim ext As Variant
    Dim fileName As String
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    extensions = Array(".jpg", ".jpeg", ".png", ".bmp", ".gif")
    
    If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"
    
    For Each ext In extensions
        fileName = folderPath & baseName & ext
        If fso.FileExists(fileName) Then
            FindImage = fileName
            Exit Function
        End If
    Next ext
    
    FindImage = ""  ' 未找到图片
End Function

Sub InsertImage(filePath As String, imgHeight As Single)
    Dim img As InlineShape
    
    On Error Resume Next  ' 防止图片插入失败
    Set img = Selection.InlineShapes.AddPicture( _
        fileName:=filePath, _
        LinkToFile:=False, _
        SaveWithDocument:=True)
    
    If Err.Number <> 0 Then
        MsgBox "无法插入图片: " & filePath, vbExclamation
        Exit Sub
    End If
    
    ' 设置图片高度并锁定纵横比
    With img
        .LockAspectRatio = msoTrue  ' 锁定纵横比
        .Height = imgHeight         ' 设置高度（宽度自动调整）
    End With
    
    ' 设置图片居中
    Selection.Paragraphs.Alignment = wdAlignParagraphCenter
    Selection.TypeParagraph
End Sub

Sub InsertPageBreak()
    Selection.InsertBreak Type:=wdPageBreak
    Selection.TypeParagraph
End Sub

Function CentimetersToPoints(cm As Single) As Single
    ' 将厘米转换为磅 (1厘米 = 28.35磅)
    CentimetersToPoints = cm * 28.35
End Function