扫描图片(多项目)批量转成(导出)文档实操(VBA2.7)

🤔🤔VBA代码如下。是2.6版本。
'==============================================================================
' 模块名称：扫描件转文档
' 版    本：v2.6 2026-04-10(9时47分)周五最终定●●●●
' 作    者：繁花
' 功    能：将同项目扫描图片批量合并，导出高清 DOCX（可选 PDF）
' 改进内容：
'   1. 修复了数字溢出问题，支持任意长度的数字序号
'   2. 添加了图片方向检测，自动调整页面方向
'   3. 优化了分页逻辑，避免多余的空白页
'   4. 增加了长路径支持，处理超过260字符的路径
'   5. 增强了错误处理，提高了代码健壮性
'   6. 优化了内存使用，支持处理大量图片
'   7. 修复了第一页图片显示较小的问题，确保所有页面大小一致
'   8. 添加了图片压缩控制参数，默认不压缩以保持原始质量
'   9. 修复了快速排序函数中的下标越界错误
'==============================================================================
' ┌─────────────────────────────────────────────────────────────────────────┐
' │                        用户可调参数区（BEGIN）                           │
' └─────────────────────────────────────────────────────────────────────────┘

' ── 是否同时导出 PDF（True=导出，False=仅 DOCX）
Private Const EXPORT_PDF        As Boolean = False

' ── 是否递归处理子文件夹（True=递归，False=仅当前层）
Private Const RECURSE_SUBFOLDERS As Boolean = False

' ── 页面边距（磅，1厘米≈28.35磅；默认四边各 36 磅 ≈ 1.27 cm）
Private Const MARGIN_TOP        As Single = 36
Private Const MARGIN_BOTTOM     As Single = 36
Private Const MARGIN_LEFT       As Single = 36
Private Const MARGIN_RIGHT      As Single = 36

' ── 页面尺寸（磅）：默认 A4（595 × 842）
Private Const PAGE_WIDTH        As Single = 595
Private Const PAGE_HEIGHT       As Single = 842

' ── PDF 导出质量（WPS/Word ExportAsFixedFormat 的 Quality 参数）
'    0 = wdExportOptimizeForPrint（高质量，文件较大）
'    1 = wdExportOptimizeForOnScreen（屏幕阅读，文件较小）
Private Const PDF_QUALITY       As Integer = 0

' ── 是否压缩图片（True=压缩，False=不压缩）
'    建议：False（不压缩）以保持原始图片质量
Private Const COMPRESS_IMAGES   As Boolean = False

' ── 支持的图片扩展名（逗号分隔，小写）
Private Const IMG_EXTS          As String = ".jpg,.jpeg,.png,.bmp,.gif,.tif,.tiff,.webp"

' ┌─────────────────────────────────────────────────────────────────────────┐
' │                        用户可调参数区（END）                             │
' └─────────────────────────────────────────────────────────────────────────┘

'==============================================================================
' 数据结构：项目信息
'==============================================================================
Private Type ProjectInfo
    projName    As String       ' 项目名称（去掉序号的公共部分）
    folderPath  As String       ' 所在文件夹
    Files()     As String       ' 按序号排好的文件完整路径列表
    fileCount   As Long         ' 图片张数
End Type

'==============================================================================
' 主入口
'==============================================================================
Public Sub 扫描件转文档99()

    ' ── 1. 选择目录 ──────────────────────────────────────────────────────
    Dim folderPath As String
    folderPath = PickFolder("请选择扫描件所在文件夹")
    If folderPath = "" Then
        MsgBox "已取消操作。", vbInformation, "已取消"
        Exit Sub
    End If

    ' ── 2. 扫描并分组 ─────────────────────────────────────────────────────
    Application.StatusBar = "正在扫描文件夹..."
    Dim projects()  As ProjectInfo
    Dim projCount   As Long
    projCount = 0

    CollectProjects folderPath, RECURSE_SUBFOLDERS, projects, projCount

    If projCount = 0 Then
        MsgBox "在所选目录中未找到任何符合条件的图片文件。" & vbCrLf & _
               "（支持格式：" & IMG_EXTS & "）", vbExclamation, "未找到图片"
        Application.StatusBar = False
        Exit Sub
    End If

    ' ── 3. 汇报给用户 ─────────────────────────────────────────────────────
    Dim summary As String
    summary = "扫描完成，共发现 " & projCount & " 个项目：" & vbCrLf & vbCrLf
    Dim pi As Long
    For pi = 0 To projCount - 1
        summary = summary & "  【" & projects(pi).projName & "】  " & _
                  projects(pi).fileCount & " 张" & vbCrLf
    Next pi
    summary = summary & vbCrLf & "即将按项目依次生成 DOCX 文件"
    If EXPORT_PDF Then summary = summary & " 并导出 PDF"
    summary = summary & "，是否继续？"

    If MsgBox(summary, vbQuestion + vbYesNo, "确认操作") = vbNo Then
        MsgBox "已取消操作。", vbInformation, "已取消"
        Application.StatusBar = False
        Exit Sub
    End If

    ' ── 4. 日志数据结构初始化 ──────────────────────────────────────────────
    Dim logRows()   As String   ' 每条日志一行，格式固定
    Dim logCount    As Long
    logCount = 0
    ReDim logRows(0 To projCount * 3)

    ' ── 5. 逐项目处理 ─────────────────────────────────────────────────────
    Dim successCount As Long
    Dim skipCount    As Long
    Dim failCount    As Long
    successCount = 0: skipCount = 0: failCount = 0

    For pi = 0 To projCount - 1
        Application.StatusBar = "处理中 [" & (pi + 1) & "/" & projCount & "]：" & projects(pi).projName

        Dim docxPath    As String
        Dim pdfPath     As String
        docxPath = projects(pi).folderPath & projects(pi).projName & "_扫描件.docx"
        pdfPath = projects(pi).folderPath & projects(pi).projName & "_扫描件.pdf"

        Dim docxExists  As Boolean
        docxExists = (Dir(docxPath) <> "")

        Dim needGenDocx As Boolean
        Dim needGenPdf  As Boolean
        needGenDocx = Not docxExists
        needGenPdf = False

        ' ── 5a. DOCX 已存在时的处理 ──────────────────────────────────────
        If docxExists Then
            Dim skipMsg As String
            skipMsg = "项目【" & projects(pi).projName & "】的 DOCX 文件已存在：" & vbCrLf & _
                      docxPath & vbCrLf & vbCrLf
            If EXPORT_PDF Then
                skipMsg = skipMsg & "是否跳过生成 DOCX，直接转换 PDF？"
                Dim skipResp As VbMsgBoxResult
                skipResp = MsgBox(skipMsg, vbQuestion + vbYesNoCancel, "DOCX 已存在")
                If skipResp = vbYes Then
                    needGenDocx = False
                    needGenPdf = True
                ElseIf skipResp = vbNo Then
                    needGenDocx = False
                    needGenPdf = False
                Else  ' Cancel = 跳过整个项目
                    AddLog logRows, logCount, projects(pi).projName, "跳过（用户取消）", "", ""
                    skipCount = skipCount + 1
                    GoTo NextProject
                End If
            Else
                skipMsg = skipMsg & "（PDF 导出已关闭）是否跳过此项目？"
                If MsgBox(skipMsg, vbQuestion + vbYesNo, "DOCX 已存在") = vbYes Then
                    AddLog logRows, logCount, projects(pi).projName, "跳过（DOCX 已存在）", docxPath, ""
                    skipCount = skipCount + 1
                    GoTo NextProject
                Else
                    needGenDocx = False  ' 用户选择跳过但不处理PDF，相当于跳过
                    AddLog logRows, logCount, projects(pi).projName, "跳过（DOCX 已存在）", docxPath, ""
                    skipCount = skipCount + 1
                    GoTo NextProject
                End If
            End If
        Else
            ' DOCX 不存在，正常生成；若开关打开也生成 PDF
            needGenDocx = True
            needGenPdf = EXPORT_PDF
        End If

        ' ── 5b. 生成 DOCX ─────────────────────────────────────────────────
        Dim wdApp   As Object
        Dim wdDoc   As Object
        Dim errStr  As String
        errStr = ""

        If needGenDocx Then
            On Error Resume Next
            Set wdApp = GetWordApp()
            On Error GoTo 0

            If wdApp Is Nothing Then
                errStr = "无法启动 Word/WPS"
                GoTo LogFail
            End If

            On Error Resume Next
            Set wdDoc = BuildDocx(wdApp, projects(pi))
            Dim buildErr As String
            buildErr = ""
            If Err.Number <> 0 Then buildErr = Err.Description
            On Error GoTo 0

            If wdDoc Is Nothing Or buildErr <> "" Then
                errStr = "生成 DOCX 失败：" & buildErr
                CleanWordApp wdApp
                GoTo LogFail
            End If

            ' 保存 DOCX
            On Error Resume Next
            wdDoc.SaveAs2 docxPath, 16   ' 16 = wdFormatXMLDocument (docx)
            Dim saveErr As Long
            saveErr = Err.Number
            On Error GoTo 0

            If saveErr <> 0 Then
                errStr = "DOCX 另存失败（错误 " & saveErr & "）"
                wdDoc.Close False
                Set wdDoc = Nothing
                CleanWordApp wdApp
                GoTo LogFail
            End If
        End If

        ' ── 5c. 导出 PDF ──────────────────────────────────────────────────
        If needGenPdf Then
            ' 若 DOCX 是刚生成的，wdDoc 已在内存；若仅转 PDF，需打开已有 DOCX
            If wdApp Is Nothing Then
                On Error Resume Next
                Set wdApp = GetWordApp()
                On Error GoTo 0
            End If

            If wdDoc Is Nothing Then
                On Error Resume Next
                Set wdDoc = wdApp.Documents.Open(docxPath, False, True)  ' ReadOnly
                If Err.Number <> 0 Then
                    errStr = "打开 DOCX 失败（" & Err.Description & "）"
                    Err.Clear
                End If
                On Error GoTo 0
            End If

            If wdDoc Is Nothing Then GoTo LogFail

            Dim pdfOk As Boolean
            pdfOk = ExportPdf(wdDoc, pdfPath)
            If Not pdfOk Then
                ' 降级：打印机驱动
                pdfOk = ExportPdfViaPrinter(wdDoc, pdfPath)
            End If
            If Not pdfOk Then
                errStr = "PDF 导出失败（两种方式均不可用）"
            End If
        End If

        ' ── 5d. 收尾 ──────────────────────────────────────────────────────
        If Not wdDoc Is Nothing Then
            wdDoc.Close False
            Set wdDoc = Nothing
        End If
        CleanWordApp wdApp

        If errStr = "" Then
            Dim pdfPathLog As String
            pdfPathLog = IIf(needGenPdf, pdfPath, "")
            AddLog logRows, logCount, projects(pi).projName, "成功", _
                   IIf(needGenDocx, docxPath, "（已跳过，既有）"), pdfPathLog
            successCount = successCount + 1
        Else
LogFail:
            AddLog logRows, logCount, projects(pi).projName, "失败：" & errStr, docxPath, ""
            failCount = failCount + 1
        End If

NextProject:
    Next pi

    Application.StatusBar = False

    ' ── 6. 询问是否保存日志 ───────────────────────────────────────────────
    Dim finalMsg As String
    finalMsg = "处理完成！" & vbCrLf & vbCrLf & _
               "  成功：" & successCount & " 个" & vbCrLf & _
               "  跳过：" & skipCount & " 个" & vbCrLf & _
               "  失败：" & failCount & " 个"
    MsgBox finalMsg, IIf(failCount > 0, vbExclamation, vbInformation), "完成"

    If MsgBox("是否将本次操作日志导出为 Excel 表格？", _
              vbQuestion + vbYesNo, "导出日志") = vbYes Then
        ExportLog logRows, logCount, folderPath
    End If

    ' ── 7. 询问是否删除原图片 ─────────────────────────────────────────────
    Dim delMsg As String
    delMsg = "是否删除本次已处理的原始扫描图片？" & vbCrLf & vbCrLf & _
             "??  此操作不可恢复，强烈建议确认 DOCX/PDF 无误后再删除。" & vbCrLf & _
             "（推荐选择：否）"
    If MsgBox(delMsg, vbExclamation + vbYesNo + vbDefaultButton2, "删除原图？") = vbYes Then
        Dim delCount As Long
        delCount = 0
        Dim delFail As Long
        delFail = 0
        For pi = 0 To projCount - 1
            Dim fi As Long
            For fi = 0 To projects(pi).fileCount - 1
                On Error Resume Next
                Kill projects(pi).Files(fi)
                If Err.Number = 0 Then
                    delCount = delCount + 1
                Else
                    delFail = delFail + 1
                End If
                Err.Clear
                On Error GoTo 0
            Next fi
        Next pi
        MsgBox "已删除 " & delCount & " 个文件" & _
               IIf(delFail > 0, "，" & delFail & " 个删除失败（可能已被占用）", "") & "。", _
               vbInformation, "删除完成"
    End If

End Sub

'==============================================================================
' 扫描文件夹，构建项目分组
'==============================================================================
Private Sub CollectProjects(ByVal folderPath As String, _
                             ByVal recurse As Boolean, _
                             ByRef projects() As ProjectInfo, _
                             ByRef projCount As Long)

    ' 收集该文件夹下所有支持的图片文件
    Dim allFiles()  As String
    Dim fileCount   As Long
    fileCount = 0
    ' 初始化为较大的数组，减少扩容次数
    ReDim allFiles(0 To 16383) ' 16K 初始容量

    GatherImages folderPath, recurse, allFiles, fileCount

    If fileCount = 0 Then Exit Sub

    ' 对文件列表排序（自然排序以确保序号正确）
    ReDim Preserve allFiles(0 To fileCount - 1)
    SortStrings allFiles, 0, fileCount - 1

    ' 按"去序号后的项目名 + 所在文件夹"分组
    ReDim projects(0 To fileCount - 1)

    Dim i As Long
    For i = 0 To fileCount - 1
        Dim fp      As String
        Dim dir_    As String
        Dim fname   As String
        Dim ext_    As String
        Dim base    As String
        Dim pname   As String

        fp = allFiles(i)
        dir_ = Left(fp, InStrRev(fp, "\"))
        fname = Mid(fp, Len(dir_) + 1)
        ext_ = GetExt(fname)
        base = Left(fname, Len(fname) - Len(ext_))
        pname = StripSeqSuffix(base)

        ' 查找是否已有同名项目（同文件夹 + 同项目名）
        Dim found As Long
        found = -1
        Dim j As Long
        For j = 0 To projCount - 1
            If projects(j).projName = pname And projects(j).folderPath = dir_ Then
                found = j
                Exit For
            End If
        Next j

        If found = -1 Then
            ' 新项目
            projects(projCount).projName = pname
            projects(projCount).folderPath = dir_
            projects(projCount).fileCount = 1
            ' 初始化为较大的数组，减少扩容次数
            ReDim projects(projCount).Files(0 To 127) ' 128 初始容量
            projects(projCount).Files(0) = fp
            projCount = projCount + 1
        Else
            ' 追加到已有项目
            Dim fc As Long
            fc = projects(found).fileCount
            If fc > UBound(projects(found).Files) Then
                ' 扩容策略：每次增加 128 个元素，减少扩容次数
                ReDim Preserve projects(found).Files(0 To fc + 127)
            End If
            projects(found).Files(fc) = fp
            projects(found).fileCount = fc + 1
        End If
    Next i

    ' 收缩每个项目的 Files 数组
    For i = 0 To projCount - 1
        ReDim Preserve projects(i).Files(0 To projects(i).fileCount - 1)
        ' 对每个项目内的文件再做一次自然排序
        SortStrings projects(i).Files, 0, projects(i).fileCount - 1
    Next i
    
    ' 收缩 projects 数组
    If projCount > 0 Then
        ReDim Preserve projects(0 To projCount - 1)
    End If
    
    ' 释放 allFiles 数组内存
    Erase allFiles

End Sub

'==============================================================================
' 递归收集图片文件
'==============================================================================
Private Function GetLongPath(ByVal path As String) As String
    ' 转换为长路径格式，支持超过260字符的路径
    If Left(path, 4) <> "\\?\" Then
        GetLongPath = "\\?\" & path
    Else
        GetLongPath = path
    End If
End Function

Private Function GetRegularPath(ByVal path As String) As String
    ' 转换回普通路径格式
    If Left(path, 4) = "\\?\" Then
        GetRegularPath = Mid(path, 5)
    Else
        GetRegularPath = path
    End If
End Function

Private Sub GatherImages(ByVal folderPath As String, _
                          ByVal recurse As Boolean, _
                          ByRef allFiles() As String, _
                          ByRef fileCount As Long)

    Dim extArr() As String
    extArr = Split(IMG_EXTS, ",")

    Dim fname As String
    fname = Dir(folderPath & "*.*")
    Do While fname <> ""
        Dim ext_ As String
        ext_ = LCase(GetExt(fname))
        Dim e As Integer
        For e = 0 To UBound(extArr)
            If Trim(extArr(e)) = ext_ Then
                If fileCount > UBound(allFiles) Then
                    ReDim Preserve allFiles(0 To UBound(allFiles) * 2 + 1)
                End If
                allFiles(fileCount) = folderPath & fname
                fileCount = fileCount + 1
                Exit For
            End If
        Next e
        fname = Dir()
    Loop

    If recurse Then
        fname = Dir(folderPath & "*", vbDirectory)
        Do While fname <> ""
            If fname <> "." And fname <> ".." Then
                Dim sub_ As String
                sub_ = folderPath & fname
                If (GetAttr(sub_) And vbDirectory) = vbDirectory Then
                    GatherImages sub_ & "\", recurse, allFiles, fileCount
                End If
            End If
            fname = Dir()
        Loop
    End If

End Sub

'==============================================================================
' 剥离文件名尾部的序号，返回项目公共名称
' 支持：名称_1 / 名称_01 / 名称001 / 名称(1) / 名称（1）
'==============================================================================
Private Function StripSeqSuffix(ByVal base As String) As String
    Dim result As String
    result = base

    ' 模式1：下划线+数字  →  项目名_123
    If result Like "*_[0-9]*" Then
        Dim pos As Long
        pos = InStrRev(result, "_")
        If pos > 0 Then
            Dim tail As String
            tail = Mid(result, pos + 1)
            If IsNumeric(tail) Then
                result = Left(result, pos - 1)
                StripSeqSuffix = result
                Exit Function
            End If
        End If
    End If

    ' 模式2：半角括号+数字  →  项目名(123)
    If result Like "*(*))" Or result Like "*(*)" Then
        Dim p1 As Long, p2 As Long
        p2 = InStrRev(result, ")")
        p1 = InStrRev(result, "(")
        If p1 > 0 And p2 = Len(result) Then
            tail = Mid(result, p1 + 1, p2 - p1 - 1)
            If IsNumeric(tail) Then
                result = Left(result, p1 - 1)
                StripSeqSuffix = result
                Exit Function
            End If
        End If
    End If

    ' 模式3：全角括号+数字  →  项目名（123）
    If InStr(result, "（") > 0 And InStr(result, "）") > 0 Then
        Dim pb As Long, pe As Long
        pe = InStrRev(result, "）")
        pb = InStrRev(result, "（")
        If pe = Len(result) And pb > 0 Then
            tail = Mid(result, pb + 1, pe - pb - 1)
            If IsNumeric(tail) Then
                result = Left(result, pb - 1)
                StripSeqSuffix = result
                Exit Function
            End If
        End If
    End If

    ' 模式4：纯数字尾缀（文件名末尾连续数字）
    Dim k As Long
    For k = Len(result) To 1 Step -1
        If Not Mid(result, k, 1) Like "[0-9]" Then Exit For
    Next k
    If k < Len(result) And k >= 1 Then
        result = Left(result, k)
        StripSeqSuffix = result
        Exit Function
    End If

    StripSeqSuffix = result
End Function

'==============================================================================
' 构建 DOCX（核心）：在 Word/WPS 中创建文档，插入图片
'==============================================================================
Private Function BuildDocx(ByVal wdApp As Object, _
                            ByRef proj As ProjectInfo) As Object

    Dim wdDoc As Object
    Set wdDoc = wdApp.Documents.Add

    ' 设置图片压缩选项
    On Error Resume Next
    If Not COMPRESS_IMAGES Then
        ' 禁用图片压缩
        wdDoc.Compatibility(140) = True ' DoNotCompressImages
        wdApp.Options.AutoCompressPictures = False
    End If
    On Error GoTo 0

    Dim rng     As Object
    Dim fi      As Long

    For fi = 0 To proj.fileCount - 1
        Set rng = wdDoc.Content
        rng.Collapse 0   ' 移到末尾（wdCollapseEnd = 0）

        ' 先获取图片信息以确定页面方向
        Dim origW As Single, origH As Single
        Dim isLandscape As Boolean
        
        ' 先通过文件系统获取图片尺寸
        Dim img As Object
        On Error Resume Next
        Set img = CreateObject("WIA.ImageFile")
        img.LoadFile proj.Files(fi)
        If Err.Number = 0 Then
            origW = img.Width
            origH = img.Height
        Else
            ' 如果WIA不可用，使用默认值
            origW = 1000 ' 假设默认宽度
            origH = 750  ' 假设默认高度
        End If
        Err.Clear
        On Error GoTo 0
        
        ' 检测图片方向
        isLandscape = (origW > origH)

        ' 先设置页面方向和尺寸
        With wdDoc.PageSetup
            If isLandscape Then
                ' 横向页面
                .Orientation = 2     ' wdOrientLandscape
                .PageWidth = PAGE_HEIGHT      ' 交换宽高
                .PageHeight = PAGE_WIDTH
            Else
                ' 纵向页面
                .Orientation = 1     ' wdOrientPortrait
                .PageWidth = PAGE_WIDTH
                .PageHeight = PAGE_HEIGHT
            End If
            .TopMargin = MARGIN_TOP
            .BottomMargin = MARGIN_BOTTOM
            .LeftMargin = MARGIN_LEFT
            .RightMargin = MARGIN_RIGHT
        End With

        ' 计算可用宽度
        Dim usableW As Single
        If isLandscape Then
            usableW = PAGE_HEIGHT - MARGIN_LEFT - MARGIN_RIGHT
        Else
            usableW = PAGE_WIDTH - MARGIN_LEFT - MARGIN_RIGHT
        End If

        ' 插入图片（LinkToFile=False, SaveWithDocument=True, InlineWithText=True）
        Dim pic As Object
        ' 使用长路径格式处理图片文件
        Dim longPath As String
        longPath = GetLongPath(proj.Files(fi))
        
        On Error Resume Next
        Set pic = wdDoc.InlineShapes.AddPicture( _
                      longPath, False, True, rng)
        If Err.Number <> 0 Then
            ' 图片插入失败，尝试使用普通路径
            longPath = GetRegularPath(proj.Files(fi))
            Err.Clear
            Set pic = wdDoc.InlineShapes.AddPicture( _
                          longPath, False, True, rng)
            If Err.Number <> 0 Then
                ' 仍然失败，插入错误信息
                rng.InsertAfter "[图片插入失败: " & proj.Files(fi) & "]"
                rng.ParagraphFormat.Alignment = 1
                Err.Clear
            End If
        End If
        On Error GoTo 0

        If Not pic Is Nothing Then
            ' 重新获取图片实际宽高
            origW = pic.Width
            origH = pic.Height

            ' 调整图片大小：宽度适应可用区域，高度等比缩放
            With pic
                If origW > usableW Then
                    .Width = usableW
                    .Height = origH * (usableW / origW)
                End If
                ' 图片居中
                .Range.ParagraphFormat.Alignment = 1   ' wdAlignParagraphCenter
            End With
        End If

        ' 每张图片后：若非最后一张，插入分页符
        If fi < proj.fileCount - 1 Then
            Set rng = wdDoc.Content
            rng.Collapse 0
            ' 确保分页符前没有多余的空行
            rng.MoveStartUntil Chr(13), -1
            If rng.Text = "" Then
                rng.Delete
            End If
            ' 插入分页符
            rng.InsertBreak 7   ' wdPageBreak = 7
        End If
    Next fi

    Set BuildDocx = wdDoc
End Function

'==============================================================================
' 获取或创建 Word 应用实例（优先用现有，避免多开）
'==============================================================================
Private Function GetWordApp() As Object
    On Error Resume Next
    Set GetWordApp = GetObject(, "Word.Application")
    If GetWordApp Is Nothing Or Err.Number <> 0 Then
        Err.Clear
        Set GetWordApp = CreateObject("Word.Application")
    End If
    If Not GetWordApp Is Nothing Then
        GetWordApp.Visible = False
    End If
    On Error GoTo 0
End Function

'==============================================================================
' 清理 Word 实例（若是本宏创建的则退出）
'==============================================================================
Private Sub CleanWordApp(ByRef wdApp As Object)
    On Error Resume Next
    If Not wdApp Is Nothing Then
        If wdApp.Documents.count = 0 Then
            wdApp.Quit False
        End If
        Set wdApp = Nothing
    End If
    On Error GoTo 0
End Sub

'==============================================================================
' 方式一：通过 ExportAsFixedFormat 导出 PDF（Word 2007+ / WPS）
'==============================================================================
Private Function ExportPdf(ByVal wdDoc As Object, _
                            ByVal pdfPath As String) As Boolean
    On Error Resume Next
    '  ExportAsFixedFormat 参数：
    '    OutputFileName, ExportFormat(17=PDF), OpenAfterExport, OptimizeFor,
    '    Range, From, To, Item, IncludeDocProps, KeepIRM, CreateBookmarks,
    '    DocStructureTags, BitmapMissingFonts, UseISO19005_1
    wdDoc.ExportAsFixedFormat pdfPath, 17, False, PDF_QUALITY
    ExportPdf = (Err.Number = 0)
    Err.Clear
    On Error GoTo 0
End Function

'==============================================================================
' 方式二：降级——通过打印机驱动导出 PDF
'==============================================================================
Private Function ExportPdfViaPrinter(ByVal wdDoc As Object, _
                                      ByVal pdfPath As String) As Boolean
    On Error Resume Next
    Dim printers() As String
    Dim candidates As String
    candidates = "Microsoft Print to PDF,WPS PDF,Adobe PDF"
    Dim cArr() As String
    cArr = Split(candidates, ",")

    Dim oldPrinter As String
    oldPrinter = wdDoc.Application.ActivePrinter

    Dim found As Boolean
    found = False
    Dim c As Integer
    For c = 0 To UBound(cArr)
        wdDoc.Application.ActivePrinter = Trim(cArr(c))
        If Err.Number = 0 Then
            found = True
            Exit For
        End If
        Err.Clear
    Next c

    If Not found Then
        wdDoc.Application.ActivePrinter = oldPrinter
        ExportPdfViaPrinter = False
        On Error GoTo 0
        Exit Function
    End If

    wdDoc.PrintOut OutputFileName:=pdfPath, PrintToFile:=True
    ExportPdfViaPrinter = (Err.Number = 0)
    Err.Clear

    wdDoc.Application.ActivePrinter = oldPrinter
    On Error GoTo 0
End Function

'==============================================================================
' 导出日志到新 Excel 工作簿
'==============================================================================
Private Sub ExportLog(ByRef logRows() As String, _
                       ByVal logCount As Long, _
                       ByVal folderPath As String)

    If logCount = 0 Then
        MsgBox "没有日志数据可导出。", vbInformation, "日志"
        Exit Sub
    End If

    Dim logWb   As Workbook
    Dim logWs   As Worksheet
    Set logWb = Workbooks.Add
    Set logWs = logWb.Sheets(1)
    logWs.Name = "操作日志"

    ' 标题行
    Dim headers As Variant
    headers = Array("序号", "时间戳", "项目名称", "状态", "DOCX路径", "PDF路径")
    Dim h As Integer
    For h = 0 To 5
        logWs.Cells(1, h + 1).Value = headers(h)
    Next h

    ' 格式化标题行
    With logWs.Range("A1:F1")
        .Font.Bold = True
        .Interior.Color = RGB(68, 114, 196)
        .Font.Color = RGB(255, 255, 255)
        .HorizontalAlignment = xlCenter
    End With

    ' 数据行
    Dim r As Long
    For r = 0 To logCount - 1
        Dim cols() As String
        cols = Split(logRows(r), Chr(1))   ' 用 Chr(1) 作内部分隔
        Dim c As Integer
        For c = 0 To UBound(cols)
            If c <= 5 Then
                logWs.Cells(r + 2, c + 1).Value = cols(c)
            End If
        Next c
    Next r

    ' 自动列宽
    logWs.Columns("A:F").AutoFit

    ' 保存
    Dim logPath As String
    logPath = folderPath & "扫描件转文档_操作日志_" & _
              Format(Now, "yyyymmdd_HHmmss") & ".xlsx"

    On Error Resume Next
    logWb.SaveAs logPath, 51   ' xlOpenXMLWorkbook
    Dim saveErr As Long
    saveErr = Err.Number
    On Error GoTo 0

    If saveErr = 0 Then
        logWb.Close False
        MsgBox "日志已保存至：" & vbCrLf & logPath, vbInformation, "日志导出成功"
    Else
        MsgBox "日志自动保存失败，工作簿已在内存中打开，请手动保存。", _
               vbExclamation, "日志保存失败"
    End If

End Sub

'==============================================================================
' 向日志数组追加一条记录
'==============================================================================
Private Sub AddLog(ByRef logRows() As String, _
                   ByRef logCount As Long, _
                   ByVal projName As String, _
                   ByVal status As String, _
                   ByVal docxPath As String, _
                   ByVal pdfPath As String)

    If logCount > UBound(logRows) Then
        ReDim Preserve logRows(0 To UBound(logRows) * 2 + 1)
    End If

    logRows(logCount) = (logCount + 1) & Chr(1) & _
                        Format(Now, "yyyy-mm-dd HH:mm:ss") & Chr(1) & _
                        projName & Chr(1) & _
                        status & Chr(1) & _
                        docxPath & Chr(1) & _
                        pdfPath
    logCount = logCount + 1
End Sub

'==============================================================================
' 弹出文件夹选择对话框
'==============================================================================
Private Function PickFolder(ByVal prompt_ As String) As String
    On Error Resume Next

    ' 优先用 FileDialog（Excel/WPS 较新版本）
    Dim fd As Object
    Set fd = Application.fileDialog(4)   ' msoFileDialogFolderPicker = 4
    If Not fd Is Nothing And Err.Number = 0 Then
        fd.Title = prompt_
        fd.AllowMultiSelect = False
        If fd.Show = -1 Then
            Dim result As String
            result = fd.SelectedItems(1)
            If Right(result, 1) <> "\" Then result = result & "\"
            PickFolder = result
        Else
            PickFolder = ""
        End If
        Err.Clear
        On Error GoTo 0
        Exit Function
    End If
    Err.Clear

    ' 降级：Shell BrowseForFolder（兼容旧版本）
    Dim shell_ As Object
    Set shell_ = CreateObject("Shell.Application")
    Dim folder_ As Object
    Set folder_ = shell_.BrowseForFolder(0, prompt_, 0)
    If Not folder_ Is Nothing Then
        Dim path_ As String
        path_ = folder_.Self.path
        If Right(path_, 1) <> "\" Then path_ = path_ & "\"
        PickFolder = path_
    Else
        PickFolder = ""
    End If
    On Error GoTo 0
End Function

'==============================================================================
' 快速排序（自然排序友好：按文件名字典序）
'==============================================================================
Private Sub SortStrings(ByRef arr() As String, _
                         ByVal lo As Long, _
                         ByVal hi As Long)
    If lo >= hi Then Exit Sub
    Dim pivot As String
    pivot = arr((lo + hi) \ 2)
    Dim i As Long, j As Long
    i = lo: j = hi
    Do
        Do While i <= hi And NaturalCompare(arr(i), pivot) < 0: i = i + 1: Loop
        Do While j >= lo And NaturalCompare(arr(j), pivot) > 0: j = j - 1: Loop
        If i <= j Then
            Dim tmp As String
            tmp = arr(i): arr(i) = arr(j): arr(j) = tmp
            i = i + 1: j = j - 1
        End If
    Loop While i <= j
    If lo < j Then SortStrings arr, lo, j
    If i < hi Then SortStrings arr, i, hi
End Sub

'==============================================================================
' 自然排序比较：将路径中的连续数字段作为数值比较
' 确保 文件_9 < 文件_10（而非字典序 文件_10 < 文件_9）
'==============================================================================
Private Function NaturalCompare(ByVal a As String, ByVal b As String) As Long
    Dim ia As Long, ib As Long
    ia = 1: ib = 1
    Do While ia <= Len(a) And ib <= Len(b)
        Dim ca As String, cb As String
        ca = Mid(a, ia, 1): cb = Mid(b, ib, 1)
        If ca Like "[0-9]" And cb Like "[0-9]" Then
            ' 提取完整数字段
            Dim na As String, nb As String
            na = "": nb = ""
            Do While ia <= Len(a) And Mid(a, ia, 1) Like "[0-9]"
                na = na & Mid(a, ia, 1): ia = ia + 1
            Loop
            Do While ib <= Len(b) And Mid(b, ib, 1) Like "[0-9]"
                nb = nb & Mid(b, ib, 1): ib = ib + 1
            Loop
            ' 比较数字段：先比较长度，长度相同再逐位比较
            If Len(na) > Len(nb) Then
                NaturalCompare = 1
                Exit Function
            ElseIf Len(na) < Len(nb) Then
                NaturalCompare = -1
                Exit Function
            Else
                ' 长度相同，逐位比较
                Dim i As Long
                For i = 1 To Len(na)
                    Dim da As Byte, db As Byte
                    da = Asc(Mid(na, i, 1))
                    db = Asc(Mid(nb, i, 1))
                    If da > db Then
                        NaturalCompare = 1
                        Exit Function
                    ElseIf da < db Then
                        NaturalCompare = -1
                        Exit Function
                    End If
                Next i
            End If
        Else
            If ca <> cb Then
                NaturalCompare = Asc(LCase(ca)) - Asc(LCase(cb))
                Exit Function
            End If
            ia = ia + 1: ib = ib + 1
        End If
    Loop
    NaturalCompare = (Len(a) - Len(b))
End Function

'==============================================================================
' 获取文件扩展名（含点，小写）
'==============================================================================
Private Function GetExt(ByVal fname As String) As String
    Dim dot As Integer
    dot = InStrRev(fname, ".")
    If dot > 0 Then
        GetExt = LCase(Mid(fname, dot))
    Else
        GetExt = ""
    End If
End Function

'==============================================================================
' 模块名称：扫描件转文档
' 版    本：v2.7 2026-05-06
' 作    者：繁花
' 功    能：将同项目扫描图片批量合并，导出高清 DOCX（可选 PDF）
' v2.7 修复内容：
'   1. 【核心修复】每个项目独立创建/销毁 Word 实例，彻底隔离 COM 崩溃传播
'      （原因：某项目导致 Word 进程不稳定后，后续项目共用同一实例全部失败）
'   2. 修复 BuildDocx 中错误信息无法正确返回的 bug
'      （原因：On Error Resume Next 之后 Err 对象在赋值给 buildErr 前已被清除）
'   3. CleanWordApp 改为强制退出，避免残留僵尸进程被下一个项目复用
'   4. WIA 图片尺寸获取失败时更健壮的降级处理，不再影响后续流程
'   5. 修复 BuildDocx 分页符插入时范围操作可能引发 COM 错误的问题
'   6. 优化错误提示，区分"Word 启动失败"与"文档构建失败"
'==============================================================================
' ┌─────────────────────────────────────────────────────────────────────────┐
' │                        用户可调参数区（BEGIN）                           │
' └─────────────────────────────────────────────────────────────────────────┘

' ── 是否同时导出 PDF（True=导出，False=仅 DOCX）
Private Const EXPORT_PDF        As Boolean = False

' ── 是否递归处理子文件夹（True=递归，False=仅当前层）
Private Const RECURSE_SUBFOLDERS As Boolean = False

' ── 页面边距（磅，1厘米≈28.35磅；默认四边各 36 磅 ≈ 1.27 cm）
Private Const MARGIN_TOP        As Single = 36
Private Const MARGIN_BOTTOM     As Single = 36
Private Const MARGIN_LEFT       As Single = 36
Private Const MARGIN_RIGHT      As Single = 36

' ── 页面尺寸（磅）：默认 A4（595 × 842）
Private Const PAGE_WIDTH        As Single = 595
Private Const PAGE_HEIGHT       As Single = 842

' ── PDF 导出质量（WPS/Word ExportAsFixedFormat 的 Quality 参数）
'    0 = wdExportOptimizeForPrint（高质量，文件较大）
'    1 = wdExportOptimizeForOnScreen（屏幕阅读，文件较小）
Private Const PDF_QUALITY       As Integer = 0

' ── 是否压缩图片（True=压缩，False=不压缩）
'    建议：False（不压缩）以保持原始图片质量
Private Const COMPRESS_IMAGES   As Boolean = False

' ── 支持的图片扩展名（逗号分隔，小写）
Private Const IMG_EXTS          As String = ".jpg,.jpeg,.png,.bmp,.gif,.tif,.tiff,.webp"

' ┌─────────────────────────────────────────────────────────────────────────┐
' │                        用户可调参数区（END）                             │
' └─────────────────────────────────────────────────────────────────────────┘

'==============================================================================
' 数据结构：项目信息
'==============================================================================
Private Type ProjectInfo
    projName    As String       ' 项目名称（去掉序号的公共部分）
    folderPath  As String       ' 所在文件夹
    Files()     As String       ' 按序号排好的文件完整路径列表
    fileCount   As Long         ' 图片张数
End Type

'==============================================================================
' 主入口
'==============================================================================
Public Sub 扫描件转文档99()

    ' ── 1. 选择目录 ──────────────────────────────────────────────────────
    Dim folderPath As String
    folderPath = PickFolder("请选择扫描件所在文件夹")
    If folderPath = "" Then
        MsgBox "已取消操作。", vbInformation, "已取消"
        Exit Sub
    End If

    ' ── 2. 扫描并分组 ─────────────────────────────────────────────────────
    Application.StatusBar = "正在扫描文件夹..."
    Dim projects()  As ProjectInfo
    Dim projCount   As Long
    projCount = 0

    CollectProjects folderPath, RECURSE_SUBFOLDERS, projects, projCount

    If projCount = 0 Then
        MsgBox "在所选目录中未找到任何符合条件的图片文件。" & vbCrLf & _
               "（支持格式：" & IMG_EXTS & "）", vbExclamation, "未找到图片"
        Application.StatusBar = False
        Exit Sub
    End If

    ' ── 3. 汇报给用户 ─────────────────────────────────────────────────────
    Dim summary As String
    summary = "扫描完成，共发现 " & projCount & " 个项目：" & vbCrLf & vbCrLf
    Dim pi As Long
    For pi = 0 To projCount - 1
        summary = summary & "  【" & projects(pi).projName & "】  " & _
                  projects(pi).fileCount & " 张" & vbCrLf
    Next pi
    summary = summary & vbCrLf & "即将按项目依次生成 DOCX 文件"
    If EXPORT_PDF Then summary = summary & " 并导出 PDF"
    summary = summary & "，是否继续？"

    If MsgBox(summary, vbQuestion + vbYesNo, "确认操作") = vbNo Then
        MsgBox "已取消操作。", vbInformation, "已取消"
        Application.StatusBar = False
        Exit Sub
    End If

    ' ── 4. 日志数据结构初始化 ──────────────────────────────────────────────
    Dim logRows()   As String
    Dim logCount    As Long
    logCount = 0
    ReDim logRows(0 To projCount * 3)

    ' ── 5. 逐项目处理 ─────────────────────────────────────────────────────
    Dim successCount As Long
    Dim skipCount    As Long
    Dim failCount    As Long
    successCount = 0: skipCount = 0: failCount = 0

    For pi = 0 To projCount - 1
        Application.StatusBar = "处理中 [" & (pi + 1) & "/" & projCount & "]：" & projects(pi).projName

        Dim docxPath    As String
        Dim pdfPath     As String
        docxPath = projects(pi).folderPath & projects(pi).projName & "_扫描件.docx"
        pdfPath  = projects(pi).folderPath & projects(pi).projName & "_扫描件.pdf"

        Dim docxExists  As Boolean
        docxExists = (Dir(docxPath) <> "")

        Dim needGenDocx As Boolean
        Dim needGenPdf  As Boolean
        needGenDocx = Not docxExists
        needGenPdf  = False

        ' ── 5a. DOCX 已存在时的处理 ──────────────────────────────────────
        If docxExists Then
            Dim skipMsg As String
            skipMsg = "项目【" & projects(pi).projName & "】的 DOCX 文件已存在：" & vbCrLf & _
                      docxPath & vbCrLf & vbCrLf
            If EXPORT_PDF Then
                skipMsg = skipMsg & "是否跳过生成 DOCX，直接转换 PDF？"
                Dim skipResp As VbMsgBoxResult
                skipResp = MsgBox(skipMsg, vbQuestion + vbYesNoCancel, "DOCX 已存在")
                If skipResp = vbYes Then
                    needGenDocx = False
                    needGenPdf  = True
                ElseIf skipResp = vbNo Then
                    needGenDocx = False
                    needGenPdf  = False
                Else
                    AddLog logRows, logCount, projects(pi).projName, "跳过（用户取消）", "", ""
                    skipCount = skipCount + 1
                    GoTo NextProject
                End If
            Else
                skipMsg = skipMsg & "（PDF 导出已关闭）是否跳过此项目？"
                If MsgBox(skipMsg, vbQuestion + vbYesNo, "DOCX 已存在") = vbYes Then
                    AddLog logRows, logCount, projects(pi).projName, "跳过（DOCX 已存在）", docxPath, ""
                    skipCount = skipCount + 1
                    GoTo NextProject
                Else
                    needGenDocx = False
                    AddLog logRows, logCount, projects(pi).projName, "跳过（DOCX 已存在）", docxPath, ""
                    skipCount = skipCount + 1
                    GoTo NextProject
                End If
            End If
        Else
            needGenDocx = True
            needGenPdf  = EXPORT_PDF
        End If

        ' ── 5b. 生成 DOCX ─────────────────────────────────────────────────
        ' v2.7：每个项目独立启动/销毁 Word 实例，防止 COM 错误跨项目传播
        Dim wdApp   As Object
        Dim wdDoc   As Object
        Dim errStr  As String
        errStr = ""
        Set wdApp = Nothing
        Set wdDoc = Nothing

        If needGenDocx Then
            ' 每次都新建独立 Word 实例
            Set wdApp = CreateFreshWordApp()

            If wdApp Is Nothing Then
                errStr = "无法启动 Word/WPS，请检查 Office 安装"
                GoTo LogFail
            End If

            ' 构建文档，内部错误通过 errStr 参数返回
            Set wdDoc = BuildDocx(wdApp, projects(pi), errStr)

            If wdDoc Is Nothing Then
                ' errStr 已由 BuildDocx 填写
                If errStr = "" Then errStr = "生成 DOCX 失败（未知原因）"
                ForceQuitWordApp wdApp
                GoTo LogFail
            End If

            ' 保存 DOCX
            Dim saveErr As Long
            saveErr = SaveDocxFile(wdDoc, docxPath)

            If saveErr <> 0 Then
                errStr = "DOCX 另存失败（错误码 " & saveErr & "）"
                On Error Resume Next
                wdDoc.Close False
                On Error GoTo 0
                Set wdDoc = Nothing
                ForceQuitWordApp wdApp
                GoTo LogFail
            End If
        End If

        ' ── 5c. 导出 PDF ──────────────────────────────────────────────────
        If needGenPdf Then
            If wdApp Is Nothing Then
                Set wdApp = CreateFreshWordApp()
            End If

            If wdDoc Is Nothing And Not wdApp Is Nothing Then
                On Error Resume Next
                Set wdDoc = wdApp.Documents.Open(docxPath, False, True)
                If Err.Number <> 0 Then
                    errStr = "打开 DOCX 失败（" & Err.Description & "）"
                    Err.Clear
                End If
                On Error GoTo 0
            End If

            If wdDoc Is Nothing Then GoTo LogFail

            Dim pdfOk As Boolean
            pdfOk = ExportPdf(wdDoc, pdfPath)
            If Not pdfOk Then pdfOk = ExportPdfViaPrinter(wdDoc, pdfPath)
            If Not pdfOk Then errStr = "PDF 导出失败（两种方式均不可用）"
        End If

        ' ── 5d. 收尾：关闭文档，强制退出本项目的 Word 实例 ─────────────────
        If Not wdDoc Is Nothing Then
            On Error Resume Next
            wdDoc.Close False
            On Error GoTo 0
            Set wdDoc = Nothing
        End If
        ForceQuitWordApp wdApp

        If errStr = "" Then
            Dim pdfPathLog As String
            pdfPathLog = IIf(needGenPdf, pdfPath, "")
            AddLog logRows, logCount, projects(pi).projName, "成功", _
                   IIf(needGenDocx, docxPath, "（已跳过，既有）"), pdfPathLog
            successCount = successCount + 1
        Else
LogFail:
            AddLog logRows, logCount, projects(pi).projName, "失败：" & errStr, docxPath, ""
            failCount = failCount + 1
            ' 确保残留实例被清理
            If Not wdDoc Is Nothing Then
                On Error Resume Next: wdDoc.Close False: On Error GoTo 0
                Set wdDoc = Nothing
            End If
            ForceQuitWordApp wdApp
        End If

NextProject:
    Next pi

    Application.StatusBar = False

    ' ── 6. 完成提示 ───────────────────────────────────────────────────────
    Dim finalMsg As String
    finalMsg = "处理完成！" & vbCrLf & vbCrLf & _
               "  成功：" & successCount & " 个" & vbCrLf & _
               "  跳过：" & skipCount & " 个" & vbCrLf & _
               "  失败：" & failCount & " 个"
    MsgBox finalMsg, IIf(failCount > 0, vbExclamation, vbInformation), "完成"

    If MsgBox("是否将本次操作日志导出为 Excel 表格？", _
              vbQuestion + vbYesNo, "导出日志") = vbYes Then
        ExportLog logRows, logCount, folderPath
    End If

    ' ── 7. 询问是否删除原图片 ─────────────────────────────────────────────
    Dim delMsg As String
    delMsg = "是否删除本次已处理的原始扫描图片？" & vbCrLf & vbCrLf & _
             "⚠  此操作不可恢复，强烈建议确认 DOCX/PDF 无误后再删除。" & vbCrLf & _
             "（推荐选择：否）"
    If MsgBox(delMsg, vbExclamation + vbYesNo + vbDefaultButton2, "删除原图？") = vbYes Then
        Dim delCount As Long, delFail As Long
        delCount = 0: delFail = 0
        For pi = 0 To projCount - 1
            Dim fi As Long
            For fi = 0 To projects(pi).fileCount - 1
                On Error Resume Next
                Kill projects(pi).Files(fi)
                If Err.Number = 0 Then delCount = delCount + 1 Else delFail = delFail + 1
                Err.Clear
                On Error GoTo 0
            Next fi
        Next pi
        MsgBox "已删除 " & delCount & " 个文件" & _
               IIf(delFail > 0, "，" & delFail & " 个删除失败（可能已被占用）", "") & "。", _
               vbInformation, "删除完成"
    End If

End Sub

'==============================================================================
' v2.7 新增：创建全新的 Word 实例（不复用现有，确保干净状态）
'==============================================================================
Private Function CreateFreshWordApp() As Object
    Dim wdApp As Object
    On Error Resume Next
    Set wdApp = CreateObject("Word.Application")
    If Err.Number <> 0 Then
        Err.Clear
        ' 尝试 WPS
        Set wdApp = CreateObject("Kwps.Application")
    End If
    On Error GoTo 0

    If Not wdApp Is Nothing Then
        On Error Resume Next
        wdApp.Visible = False
        On Error GoTo 0
    End If

    Set CreateFreshWordApp = wdApp
End Function

'==============================================================================
' v2.7 新增：强制退出 Word 实例（无论文档是否打开）
'==============================================================================
Private Sub ForceQuitWordApp(ByRef wdApp As Object)
    If wdApp Is Nothing Then Exit Sub
    On Error Resume Next
    ' 关闭所有文档（不保存）
    Dim i As Long
    For i = wdApp.Documents.Count To 1 Step -1
        wdApp.Documents(i).Close False
    Next i
    wdApp.Quit False
    On Error GoTo 0
    Set wdApp = Nothing
End Sub

'==============================================================================
' v2.7 新增：独立的 DOCX 保存函数，返回错误号（0=成功）
'==============================================================================
Private Function SaveDocxFile(ByVal wdDoc As Object, ByVal docxPath As String) As Long
    On Error Resume Next
    wdDoc.SaveAs2 docxPath, 16   ' 16 = wdFormatXMLDocument
    SaveDocxFile = Err.Number
    Err.Clear
    On Error GoTo 0
End Function

'==============================================================================
' 扫描文件夹，构建项目分组
'==============================================================================
Private Sub CollectProjects(ByVal folderPath As String, _
                             ByVal recurse As Boolean, _
                             ByRef projects() As ProjectInfo, _
                             ByRef projCount As Long)

    Dim allFiles()  As String
    Dim fileCount   As Long
    fileCount = 0
    ReDim allFiles(0 To 16383)

    GatherImages folderPath, recurse, allFiles, fileCount

    If fileCount = 0 Then Exit Sub

    ReDim Preserve allFiles(0 To fileCount - 1)
    SortStrings allFiles, 0, fileCount - 1

    ReDim projects(0 To fileCount - 1)

    Dim i As Long
    For i = 0 To fileCount - 1
        Dim fp      As String
        Dim dir_    As String
        Dim fname   As String
        Dim ext_    As String
        Dim base    As String
        Dim pname   As String

        fp    = allFiles(i)
        dir_  = Left(fp, InStrRev(fp, "\"))
        fname = Mid(fp, Len(dir_) + 1)
        ext_  = GetExt(fname)
        base  = Left(fname, Len(fname) - Len(ext_))
        pname = StripSeqSuffix(base)

        Dim found As Long
        found = -1
        Dim j As Long
        For j = 0 To projCount - 1
            If projects(j).projName = pname And projects(j).folderPath = dir_ Then
                found = j
                Exit For
            End If
        Next j

        If found = -1 Then
            projects(projCount).projName   = pname
            projects(projCount).folderPath = dir_
            projects(projCount).fileCount  = 1
            ReDim projects(projCount).Files(0 To 127)
            projects(projCount).Files(0) = fp
            projCount = projCount + 1
        Else
            Dim fc As Long
            fc = projects(found).fileCount
            If fc > UBound(projects(found).Files) Then
                ReDim Preserve projects(found).Files(0 To fc + 127)
            End If
            projects(found).Files(fc) = fp
            projects(found).fileCount = fc + 1
        End If
    Next i

    For i = 0 To projCount - 1
        ReDim Preserve projects(i).Files(0 To projects(i).fileCount - 1)
        SortStrings projects(i).Files, 0, projects(i).fileCount - 1
    Next i

    If projCount > 0 Then ReDim Preserve projects(0 To projCount - 1)
    Erase allFiles

End Sub

'==============================================================================
' 递归收集图片文件
'==============================================================================
Private Function GetLongPath(ByVal path As String) As String
    If Left(path, 4) <> "\\?\" Then
        GetLongPath = "\\?\" & path
    Else
        GetLongPath = path
    End If
End Function

Private Function GetRegularPath(ByVal path As String) As String
    If Left(path, 4) = "\\?\" Then
        GetRegularPath = Mid(path, 5)
    Else
        GetRegularPath = path
    End If
End Function

Private Sub GatherImages(ByVal folderPath As String, _
                          ByVal recurse As Boolean, _
                          ByRef allFiles() As String, _
                          ByRef fileCount As Long)

    Dim extArr() As String
    extArr = Split(IMG_EXTS, ",")

    Dim fname As String
    fname = Dir(folderPath & "*.*")
    Do While fname <> ""
        Dim ext_ As String
        ext_ = LCase(GetExt(fname))
        Dim e As Integer
        For e = 0 To UBound(extArr)
            If Trim(extArr(e)) = ext_ Then
                If fileCount > UBound(allFiles) Then
                    ReDim Preserve allFiles(0 To UBound(allFiles) * 2 + 1)
                End If
                allFiles(fileCount) = folderPath & fname
                fileCount = fileCount + 1
                Exit For
            End If
        Next e
        fname = Dir()
    Loop

    If recurse Then
        fname = Dir(folderPath & "*", vbDirectory)
        Do While fname <> ""
            If fname <> "." And fname <> ".." Then
                Dim sub_ As String
                sub_ = folderPath & fname
                If (GetAttr(sub_) And vbDirectory) = vbDirectory Then
                    GatherImages sub_ & "\", recurse, allFiles, fileCount
                End If
            End If
            fname = Dir()
        Loop
    End If

End Sub

'==============================================================================
' 剥离文件名尾部的序号，返回项目公共名称
'==============================================================================
Private Function StripSeqSuffix(ByVal base As String) As String
    Dim result As String
    result = base

    ' 模式1：下划线+数字
    If result Like "*_[0-9]*" Then
        Dim pos As Long
        pos = InStrRev(result, "_")
        If pos > 0 Then
            Dim tail As String
            tail = Mid(result, pos + 1)
            If IsNumeric(tail) Then
                StripSeqSuffix = Left(result, pos - 1)
                Exit Function
            End If
        End If
    End If

    ' 模式2：半角括号+数字
    If result Like "*(*)" Then
        Dim p1 As Long, p2 As Long
        p2 = InStrRev(result, ")")
        p1 = InStrRev(result, "(")
        If p1 > 0 And p2 = Len(result) Then
            tail = Mid(result, p1 + 1, p2 - p1 - 1)
            If IsNumeric(tail) Then
                StripSeqSuffix = Left(result, p1 - 1)
                Exit Function
            End If
        End If
    End If

    ' 模式3：全角括号+数字
    If InStr(result, "（") > 0 And InStr(result, "）") > 0 Then
        Dim pb As Long, pe As Long
        pe = InStrRev(result, "）")
        pb = InStrRev(result, "（")
        If pe = Len(result) And pb > 0 Then
            tail = Mid(result, pb + 1, pe - pb - 1)
            If IsNumeric(tail) Then
                StripSeqSuffix = Left(result, pb - 1)
                Exit Function
            End If
        End If
    End If

    ' 模式4：纯数字尾缀
    Dim k As Long
    For k = Len(result) To 1 Step -1
        If Not Mid(result, k, 1) Like "[0-9]" Then Exit For
    Next k
    If k < Len(result) And k >= 1 Then
        StripSeqSuffix = Left(result, k)
        Exit Function
    End If

    StripSeqSuffix = result
End Function

'==============================================================================
' 构建 DOCX（核心）
' v2.7：通过 errMsg 参数返回错误信息，不依赖 Err 对象跨调用传递
'==============================================================================
Private Function BuildDocx(ByVal wdApp As Object, _
                            ByRef proj As ProjectInfo, _
                            ByRef errMsg As String) As Object
    errMsg = ""
    Dim wdDoc As Object

    On Error Resume Next
    Set wdDoc = wdApp.Documents.Add
    If Err.Number <> 0 Then
        errMsg = "生成 DOCX 失败：" & Err.Description
        Err.Clear
        On Error GoTo 0
        Set BuildDocx = Nothing
        Exit Function
    End If
    On Error GoTo 0

    ' 禁用图片自动压缩
    If Not COMPRESS_IMAGES Then
        On Error Resume Next
        wdApp.Options.AutoCompressPictures = False
        On Error GoTo 0
    End If

    Dim rng As Object
    Dim fi  As Long

    For fi = 0 To proj.fileCount - 1

        ' ── 获取图片原始尺寸（用于判断横竖向）─────────────────────────────
        Dim origW As Single, origH As Single
        origW = 0: origH = 0

        On Error Resume Next
        Dim img As Object
        Set img = CreateObject("WIA.ImageFile")
        If Err.Number = 0 Then
            img.LoadFile proj.Files(fi)
            If Err.Number = 0 Then
                origW = img.Width
                origH = img.Height
            End If
        End If
        Err.Clear
        Set img = Nothing
        On Error GoTo 0

        ' WIA 失败时使用默认值（假设纵向）
        If origW = 0 Or origH = 0 Then
            origW = 1000
            origH = 1414
        End If

        Dim isLandscape As Boolean
        isLandscape = (origW > origH)

        ' ── 设置页面方向 ────────────────────────────────────────────────
        On Error Resume Next
        With wdDoc.PageSetup
            If isLandscape Then
                .Orientation = 2
                .PageWidth   = PAGE_HEIGHT
                .PageHeight  = PAGE_WIDTH
            Else
                .Orientation = 1
                .PageWidth   = PAGE_WIDTH
                .PageHeight  = PAGE_HEIGHT
            End If
            .TopMargin    = MARGIN_TOP
            .BottomMargin = MARGIN_BOTTOM
            .LeftMargin   = MARGIN_LEFT
            .RightMargin  = MARGIN_RIGHT
        End With
        If Err.Number <> 0 Then Err.Clear
        On Error GoTo 0

        ' ── 计算可用宽度 ─────────────────────────────────────────────────
        Dim usableW As Single
        usableW = IIf(isLandscape, PAGE_HEIGHT, PAGE_WIDTH) - MARGIN_LEFT - MARGIN_RIGHT

        ' ── 插入图片 ─────────────────────────────────────────────────────
        Dim pic As Object
        Set pic = Nothing

        ' 定位到文档末尾
        On Error Resume Next
        Set rng = wdDoc.Content
        rng.Collapse 0
        On Error GoTo 0

        ' 先尝试长路径，失败则普通路径
        Dim insertPath As String
        insertPath = GetLongPath(proj.Files(fi))

        On Error Resume Next
        Set pic = wdDoc.InlineShapes.AddPicture(insertPath, False, True, rng)
        If Err.Number <> 0 Or pic Is Nothing Then
            Err.Clear
            insertPath = GetRegularPath(proj.Files(fi))
            Set pic = wdDoc.InlineShapes.AddPicture(insertPath, False, True, rng)
            If Err.Number <> 0 Then
                ' 插入失败：写占位文本，继续处理下一张
                Err.Clear
                On Error GoTo 0
                On Error Resume Next
                Set rng = wdDoc.Content
                rng.Collapse 0
                rng.InsertAfter "[图片插入失败: " & proj.Files(fi) & "]"
                rng.ParagraphFormat.Alignment = 1
                Err.Clear
                On Error GoTo 0
                Set pic = Nothing
            End If
        End If
        On Error GoTo 0

        ' ── 调整图片大小及对齐 ───────────────────────────────────────────
        If Not pic Is Nothing Then
            On Error Resume Next
            Dim picW As Single, picH As Single
            picW = pic.Width
            picH = pic.Height
            If picW > 0 And picW > usableW Then
                pic.Width  = usableW
                pic.Height = picH * (usableW / picW)
            End If
            pic.Range.ParagraphFormat.Alignment = 1   ' 居中
            If Err.Number <> 0 Then Err.Clear
            On Error GoTo 0
        End If

        ' ── 分页符（非最后一张）─────────────────────────────────────────
        If fi < proj.fileCount - 1 Then
            On Error Resume Next
            Set rng = wdDoc.Content
            rng.Collapse 0   ' 移到文档末尾
            rng.InsertBreak 7   ' wdPageBreak
            If Err.Number <> 0 Then Err.Clear
            On Error GoTo 0
        End If

    Next fi

    Set BuildDocx = wdDoc
End Function

'==============================================================================
' 方式一：通过 ExportAsFixedFormat 导出 PDF
'==============================================================================
Private Function ExportPdf(ByVal wdDoc As Object, _
                            ByVal pdfPath As String) As Boolean
    On Error Resume Next
    wdDoc.ExportAsFixedFormat pdfPath, 17, False, PDF_QUALITY
    ExportPdf = (Err.Number = 0)
    Err.Clear
    On Error GoTo 0
End Function

'==============================================================================
' 方式二：降级——通过打印机驱动导出 PDF
'==============================================================================
Private Function ExportPdfViaPrinter(ByVal wdDoc As Object, _
                                      ByVal pdfPath As String) As Boolean
    On Error Resume Next
    Dim candidates As String
    candidates = "Microsoft Print to PDF,WPS PDF,Adobe PDF"
    Dim cArr() As String
    cArr = Split(candidates, ",")

    Dim oldPrinter As String
    oldPrinter = wdDoc.Application.ActivePrinter

    Dim found As Boolean
    found = False
    Dim c As Integer
    For c = 0 To UBound(cArr)
        wdDoc.Application.ActivePrinter = Trim(cArr(c))
        If Err.Number = 0 Then
            found = True
            Exit For
        End If
        Err.Clear
    Next c

    If Not found Then
        wdDoc.Application.ActivePrinter = oldPrinter
        ExportPdfViaPrinter = False
        On Error GoTo 0
        Exit Function
    End If

    wdDoc.PrintOut OutputFileName:=pdfPath, PrintToFile:=True
    ExportPdfViaPrinter = (Err.Number = 0)
    Err.Clear
    wdDoc.Application.ActivePrinter = oldPrinter
    On Error GoTo 0
End Function

'==============================================================================
' 导出日志到新 Excel 工作簿
'==============================================================================
Private Sub ExportLog(ByRef logRows() As String, _
                       ByVal logCount As Long, _
                       ByVal folderPath As String)

    If logCount = 0 Then
        MsgBox "没有日志数据可导出。", vbInformation, "日志"
        Exit Sub
    End If

    Dim logWb   As Workbook
    Dim logWs   As Worksheet
    Set logWb = Workbooks.Add
    Set logWs = logWb.Sheets(1)
    logWs.Name = "操作日志"

    Dim headers As Variant
    headers = Array("序号", "时间戳", "项目名称", "状态", "DOCX路径", "PDF路径")
    Dim h As Integer
    For h = 0 To 5
        logWs.Cells(1, h + 1).Value = headers(h)
    Next h

    With logWs.Range("A1:F1")
        .Font.Bold = True
        .Interior.Color = RGB(68, 114, 196)
        .Font.Color = RGB(255, 255, 255)
        .HorizontalAlignment = xlCenter
    End With

    Dim r As Long
    For r = 0 To logCount - 1
        Dim cols() As String
        cols = Split(logRows(r), Chr(1))
        Dim c As Integer
        For c = 0 To UBound(cols)
            If c <= 5 Then logWs.Cells(r + 2, c + 1).Value = cols(c)
        Next c
    Next r

    logWs.Columns("A:F").AutoFit

    Dim logPath As String
    logPath = folderPath & "扫描件转文档_操作日志_" & _
              Format(Now, "yyyymmdd_HHmmss") & ".xlsx"

    On Error Resume Next
    logWb.SaveAs logPath, 51
    Dim saveErr As Long
    saveErr = Err.Number
    On Error GoTo 0

    If saveErr = 0 Then
        logWb.Close False
        MsgBox "日志已保存至：" & vbCrLf & logPath, vbInformation, "日志导出成功"
    Else
        MsgBox "日志自动保存失败，工作簿已在内存中打开，请手动保存。", _
               vbExclamation, "日志保存失败"
    End If

End Sub

'==============================================================================
' 向日志数组追加一条记录
'==============================================================================
Private Sub AddLog(ByRef logRows() As String, _
                   ByRef logCount As Long, _
                   ByVal projName As String, _
                   ByVal status As String, _
                   ByVal docxPath As String, _
                   ByVal pdfPath As String)

    If logCount > UBound(logRows) Then
        ReDim Preserve logRows(0 To UBound(logRows) * 2 + 1)
    End If

    logRows(logCount) = (logCount + 1) & Chr(1) & _
                        Format(Now, "yyyy-mm-dd HH:mm:ss") & Chr(1) & _
                        projName & Chr(1) & _
                        status & Chr(1) & _
                        docxPath & Chr(1) & _
                        pdfPath
    logCount = logCount + 1
End Sub

'==============================================================================
' 弹出文件夹选择对话框
'==============================================================================
Private Function PickFolder(ByVal prompt_ As String) As String
    On Error Resume Next

    Dim fd As Object
    Set fd = Application.FileDialog(4)
    If Not fd Is Nothing And Err.Number = 0 Then
        fd.Title = prompt_
        fd.AllowMultiSelect = False
        If fd.Show = -1 Then
            Dim result As String
            result = fd.SelectedItems(1)
            If Right(result, 1) <> "\" Then result = result & "\"
            PickFolder = result
        Else
            PickFolder = ""
        End If
        Err.Clear
        On Error GoTo 0
        Exit Function
    End If
    Err.Clear

    Dim shell_ As Object
    Set shell_ = CreateObject("Shell.Application")
    Dim folder_ As Object
    Set folder_ = shell_.BrowseForFolder(0, prompt_, 0)
    If Not folder_ Is Nothing Then
        Dim path_ As String
        path_ = folder_.Self.path
        If Right(path_, 1) <> "\" Then path_ = path_ & "\"
        PickFolder = path_
    Else
        PickFolder = ""
    End If
    On Error GoTo 0
End Function

'==============================================================================
' 快速排序（自然排序）
'==============================================================================
Private Sub SortStrings(ByRef arr() As String, _
                         ByVal lo As Long, _
                         ByVal hi As Long)
    If lo >= hi Then Exit Sub
    Dim pivot As String
    pivot = arr((lo + hi) \ 2)
    Dim i As Long, j As Long
    i = lo: j = hi
    Do
        Do While i <= hi And NaturalCompare(arr(i), pivot) < 0: i = i + 1: Loop
        Do While j >= lo And NaturalCompare(arr(j), pivot) > 0: j = j - 1: Loop
        If i <= j Then
            Dim tmp As String
            tmp = arr(i): arr(i) = arr(j): arr(j) = tmp
            i = i + 1: j = j - 1
        End If
    Loop While i <= j
    If lo < j Then SortStrings arr, lo, j
    If i < hi Then SortStrings arr, i, hi
End Sub

'==============================================================================
' 自然排序比较
'==============================================================================
Private Function NaturalCompare(ByVal a As String, ByVal b As String) As Long
    Dim ia As Long, ib As Long
    ia = 1: ib = 1
    Do While ia <= Len(a) And ib <= Len(b)
        Dim ca As String, cb As String
        ca = Mid(a, ia, 1): cb = Mid(b, ib, 1)
        If ca Like "[0-9]" And cb Like "[0-9]" Then
            Dim na As String, nb As String
            na = "": nb = ""
            Do While ia <= Len(a) And Mid(a, ia, 1) Like "[0-9]"
                na = na & Mid(a, ia, 1): ia = ia + 1
            Loop
            Do While ib <= Len(b) And Mid(b, ib, 1) Like "[0-9]"
                nb = nb & Mid(b, ib, 1): ib = ib + 1
            Loop
            If Len(na) > Len(nb) Then
                NaturalCompare = 1: Exit Function
            ElseIf Len(na) < Len(nb) Then
                NaturalCompare = -1: Exit Function
            Else
                Dim i As Long
                For i = 1 To Len(na)
                    Dim da As Byte, db As Byte
                    da = Asc(Mid(na, i, 1))
                    db = Asc(Mid(nb, i, 1))
                    If da > db Then
                        NaturalCompare = 1: Exit Function
                    ElseIf da < db Then
                        NaturalCompare = -1: Exit Function
                    End If
                Next i
            End If
        Else
            If ca <> cb Then
                NaturalCompare = Asc(LCase(ca)) - Asc(LCase(cb))
                Exit Function
            End If
            ia = ia + 1: ib = ib + 1
        End If
    Loop
    NaturalCompare = (Len(a) - Len(b))
End Function

'==============================================================================
' 获取文件扩展名（含点，小写）
'==============================================================================
Private Function GetExt(ByVal fname As String) As String
    Dim dot As Integer
    dot = InStrRev(fname, ".")
    If dot > 0 Then
        GetExt = LCase(Mid(fname, dot))
    Else
        GetExt = ""
    End If
End Function