[Visual Basic] 纯文本查看 复制代码
Option Explicit
Option Private Module ' 使本模块中的过程不在宏对话框中显示，但不影响 Application.Run 调用
' ======================
' 模块级变量：文件缓存（路径列表 + 属性字典）
' ======================
Private m_arrFilePaths() As String ' 文件路径顺序列表（动态数组）
Private m_dictOrigOrient As Object ' 原始方向
Private m_dictOrigPaper As Object ' 原始纸张
Private m_dictOrigZoom As Object ' 原始缩放
Private m_dictOrigSheetCount As Object ' 原始工作表数
Private m_dictOrigPageCount As Object ' 原始页数
Private m_dictCustomOrient As Object ' 自定义方向
Private m_dictCustomPaper As Object ' 自定义纸张
Private m_dictCustomZoom As Object ' 自定义缩放
Private m_dictFileModTime As Object ' 文件最后修改时间（用于转换时校验）
Private m_dictReadStatus As Object ' 新增：分析状态（成功/失败）
' ======================
' 新增：缓存字典（用于智能打印区域优化）
' 结构：键 = 文件路径，值 = 另一个字典，包含：
' "LastModTime": Date
' "Sheets": 字典，键 = 工作表名，值 = 另一个字典（区域缓存）
' 区域缓存子字典键：
' "FullUsedRange" ' 整个UsedRange的最小矩形地址
' "TextNumRange" ' 文本/数字区域的最小矩形地址
' "FormulaRange" ' 公式区域的最小矩形地址
' "BorderRange" ' 有边框区域的最小矩形地址
' "BgColorRange" ' 有背景色区域的最小矩形地址
' "FullUsedRangeVisible" ' 剔除隐藏行列后的FullUsedRange（可选）
' "TextNumRangeVisible" ' 剔除隐藏行列后的TextNumRange
' "FormulaRangeVisible" ' 剔除隐藏行列后的FormulaRange
' "BorderRangeVisible" ' 剔除隐藏行列后的BorderRange
' "BgColorRangeVisible" ' 剔除隐藏行列后的BgColorRange
' ======================
Private m_dictFileCache As Object
' ======================
' 安全写日志（调用窗体，若窗体已加载）
' ======================
Private Sub LogToForm(msg As String)
If Not UserForm1 Is Nothing Then
UserForm1.LogMessage msg
End If
End Sub
' ======================
' 初始化/清空所有缓存
' ======================
Private Sub InitFileCache()
' 清空路径列表
Erase m_arrFilePaths
' 重新创建字典
Set m_dictOrigOrient = CreateObject("Scripting.Dictionary")
Set m_dictOrigPaper = CreateObject("Scripting.Dictionary")
Set m_dictOrigZoom = CreateObject("Scripting.Dictionary")
Set m_dictOrigSheetCount = CreateObject("Scripting.Dictionary")
Set m_dictOrigPageCount = CreateObject("Scripting.Dictionary")
Set m_dictCustomOrient = CreateObject("Scripting.Dictionary")
Set m_dictCustomPaper = CreateObject("Scripting.Dictionary")
Set m_dictCustomZoom = CreateObject("Scripting.Dictionary")
Set m_dictFileModTime = CreateObject("Scripting.Dictionary")
Set m_dictReadStatus = CreateObject("Scripting.Dictionary")
' 新增缓存字典
Set m_dictFileCache = CreateObject("Scripting.Dictionary")
End Sub
' ======================
' 获取文件总数（安全处理空数组）
' ======================
Private Function GetFileCount() As Long
On Error Resume Next
GetFileCount = UBound(m_arrFilePaths) + 1
If Err.Number <> 0 Then
GetFileCount = 0
Err.Clear
End If
On Error GoTo 0
End Function
' ======================
' 获取文件列表数据（供窗体刷新）
' 返回二维数组，每行对应一个文件，列索引与 ListBox 的列索引一致
' ======================
Public Function GetFileListData() As Variant
Dim total As Long, i As Long
total = GetFileCount()
If total = 0 Then
GetFileListData = Array()
Exit Function
End If
Dim Data() As Variant
ReDim Data(0 To total - 1, 0 To 6) ' 7列
Dim FullPath As String
Dim orient As String, paper As String, zoom As String
Dim sheetCount As Integer, pageCount As Integer
Dim status As String
For i = 0 To total - 1
FullPath = m_arrFilePaths(i)
Data(i, COL_PATH) = FullPath
Data(i, COL_NAME) = Mid(FullPath, InStrRev(FullPath, "\") + 1)
' 获取原始属性（确保字典中存在）
If m_dictOrigOrient.Exists(FullPath) Then
orient = m_dictOrigOrient(FullPath)
paper = m_dictOrigPaper(FullPath)
zoom = m_dictOrigZoom(FullPath)
sheetCount = m_dictOrigSheetCount(FullPath)
pageCount = m_dictOrigPageCount(FullPath)
status = m_dictReadStatus(FullPath) ' 获取分析状态
' 应用自定义（若存在）
If m_dictCustomOrient.Exists(FullPath) And m_dictCustomOrient(FullPath) <> "" Then
orient = m_dictCustomOrient(FullPath)
End If
If m_dictCustomPaper.Exists(FullPath) And m_dictCustomPaper(FullPath) <> "" Then
paper = m_dictCustomPaper(FullPath)
End If
If m_dictCustomZoom.Exists(FullPath) And m_dictCustomZoom(FullPath) <> "" Then
zoom = m_dictCustomZoom(FullPath)
End If
Else
' 容错：若键不存在（极少发生），提供默认值
orient = "未设"
paper = "未设"
zoom = "未设"
sheetCount = 0
pageCount = 0
status = "未分析"
End If
' 根据分析状态调整显示
If status <> "成功" Then
orient = status
paper = status
zoom = status
sheetCount = 0
pageCount = 0
End If
Data(i, COL_SHEET) = "分表：" & sheetCount
Data(i, COL_PAGE) = "页数：" & pageCount
Data(i, COL_ORIENT) = "方向：" & orient
Data(i, COL_PAPER) = "页面：" & paper
Data(i, COL_ZOOM) = "缩放：" & zoom
Next i
GetFileListData = Data
End Function
' ======================
' 添加单个文件到缓存（如果已存在则跳过）
' ======================
Public Sub AddFileToCache(FullPath As String)
' 检查是否已存在
Dim i As Long
For i = 0 To GetFileCount() - 1
If m_arrFilePaths(i) = FullPath Then Exit Sub
Next i
' 添加到路径列表
Dim newCount As Long
newCount = GetFileCount() + 1
ReDim Preserve m_arrFilePaths(0 To newCount - 1)
m_arrFilePaths(newCount - 1) = FullPath
' 初始化字典项（占位，未分析）
m_dictOrigOrient(FullPath) = "未设"
m_dictOrigPaper(FullPath) = "未设"
m_dictOrigZoom(FullPath) = "未设"
m_dictOrigSheetCount(FullPath) = 0
m_dictOrigPageCount(FullPath) = 0
m_dictReadStatus(FullPath) = "未分析" ' 初始状态
' 自定义字典初始为空（不添加键，用Exists判断）
' 记录修改时间
On Error Resume Next
m_dictFileModTime(FullPath) = FileDateTime(FullPath)
On Error GoTo 0
End Sub
' ======================
' 从缓存中删除指定文件
' ======================
Public Sub RemoveFileFromCache(FullPath As String)
Dim i As Long, idx As Long
idx = -1
For i = 0 To GetFileCount() - 1
If m_arrFilePaths(i) = FullPath Then
idx = i
Exit For
End If
Next i
If idx = -1 Then Exit Sub
' 从路径数组中删除
Dim total As Long
total = GetFileCount()
If total = 1 Then
Erase m_arrFilePaths
Else
For i = idx To total - 2
m_arrFilePaths(i) = m_arrFilePaths(i + 1)
Next i
ReDim Preserve m_arrFilePaths(0 To total - 2)
End If
' 从所有字典中移除
If m_dictOrigOrient.Exists(FullPath) Then m_dictOrigOrient.Remove FullPath
If m_dictOrigPaper.Exists(FullPath) Then m_dictOrigPaper.Remove FullPath
If m_dictOrigZoom.Exists(FullPath) Then m_dictOrigZoom.Remove FullPath
If m_dictOrigSheetCount.Exists(FullPath) Then m_dictOrigSheetCount.Remove FullPath
If m_dictOrigPageCount.Exists(FullPath) Then m_dictOrigPageCount.Remove FullPath
If m_dictCustomOrient.Exists(FullPath) Then m_dictCustomOrient.Remove FullPath
If m_dictCustomPaper.Exists(FullPath) Then m_dictCustomPaper.Remove FullPath
If m_dictCustomZoom.Exists(FullPath) Then m_dictCustomZoom.Remove FullPath
If m_dictFileModTime.Exists(FullPath) Then m_dictFileModTime.Remove FullPath
If m_dictReadStatus.Exists(FullPath) Then m_dictReadStatus.Remove FullPath
If m_dictFileCache.Exists(FullPath) Then m_dictFileCache.Remove FullPath
End Sub
' ======================
' 清空所有文件
' ======================
Public Sub ClearAllFiles()
InitFileCache
End Sub
' ======================
' 上移文件（交换位置）
' ======================
Public Sub MoveFileUp(ByVal FullPath As String)
Dim i As Long, idx As Long
For i = 0 To GetFileCount() - 1
If m_arrFilePaths(i) = FullPath Then
idx = i
Exit For
End If
Next i
If idx < 1 Then Exit Sub
Dim temp As String
temp = m_arrFilePaths(idx - 1)
m_arrFilePaths(idx - 1) = m_arrFilePaths(idx)
m_arrFilePaths(idx) = temp
End Sub
' ======================
' 下移文件
' ======================
Public Sub MoveFileDown(ByVal FullPath As String)
Dim i As Long, idx As Long
For i = 0 To GetFileCount() - 1
If m_arrFilePaths(i) = FullPath Then
idx = i
Exit For
End If
Next i
If idx >= GetFileCount() - 1 Then Exit Sub
Dim temp As String
temp = m_arrFilePaths(idx + 1)
m_arrFilePaths(idx + 1) = m_arrFilePaths(idx)
m_arrFilePaths(idx) = temp
End Sub
' ======================
' 判断是否存在任何自定义设置（供窗体调用）
' ======================
Public Function HasAnyCustomSetting() As Boolean
HasAnyCustomSetting = (m_dictCustomOrient.Count > 0 Or _
m_dictCustomPaper.Count > 0 Or _
m_dictCustomZoom.Count > 0)
End Function
' ======================
' 分析所有文件（读取原始属性，不清除自定义，同时构建缓存）
' ======================
Public Sub AnalyzeAllFiles()
Dim total As Long, i As Long
total = GetFileCount()
If total = 0 Then
LogToForm "请先添加文件！"
Exit Sub
End If
LogToForm "开始分析所有文件（读取原文件方向/尺寸/缩放，更新页数，构建缓存）..."
Application.ScreenUpdating = False
Application.DisplayAlerts = False
' 注意：不再清除自定义字典，保留用户之前可能设置的选项
' 但需要清除之前的原始属性字典，以便重新填充
m_dictOrigOrient.RemoveAll
m_dictOrigPaper.RemoveAll
m_dictOrigZoom.RemoveAll
m_dictOrigSheetCount.RemoveAll
m_dictOrigPageCount.RemoveAll
m_dictReadStatus.RemoveAll ' 重置状态
Dim FullPath As String
Dim info As New clsFileInfo
For i = 0 To total - 1
FullPath = m_arrFilePaths(i)
info.FullPath = FullPath
info.AnalyzeFile
' 方向
Dim orientText As String
Select Case info.Orientation
Case 1: orientText = "竖向"
Case 2: orientText = "横向"
Case Else: orientText = "未设"
End Select
m_dictOrigOrient.Add FullPath, orientText
' 纸张
Dim sizeText As String
Select Case info.PaperSize
Case 8: sizeText = "A3"
Case 9: sizeText = "A4"
Case Else: sizeText = "未设"
End Select
m_dictOrigPaper.Add FullPath, sizeText
' 缩放
Dim zoomText As String
If info.ZoomIsPercent And info.ZoomValue > 0 Then
zoomText = Format(info.ZoomValue, "0") & "%"
ElseIf info.ZoomIsPercent = False And info.ZoomValue = 0 Then
zoomText = "适配"
Else
zoomText = "未设"
End If
m_dictOrigZoom.Add FullPath, zoomText
' 分表数、页数
m_dictOrigSheetCount.Add FullPath, info.sheetCount
m_dictOrigPageCount.Add FullPath, info.pageCount
' 记录分析状态
m_dictReadStatus.Add FullPath, info.ReadStatus
' 记录修改时间
On Error Resume Next
m_dictFileModTime(FullPath) = FileDateTime(FullPath)
On Error GoTo 0
' 构建缓存（始终构建）
BuildFileCache FullPath
' 日志输出，区分成功/失败
If info.ReadStatus = "成功" Then
Dim pageInfo As String
If info.pageCount > 0 Then
pageInfo = "，页数：" & info.pageCount & "（估算值，非完全准确）"
Else
pageInfo = ""
End If
LogToForm "分析完成：" & info.fileName & " → " & orientText & sizeText & "/" & zoomText & pageInfo
Else
LogToForm "分析失败：" & info.fileName & " → " & info.ReadStatus
End If
Next i
Application.ScreenUpdating = True
Application.DisplayAlerts = True
' 不再输出完成日志，由窗体统一输出，避免重复
End Sub
' ======================
' 重新分析单个文件（用于右键单独分析，不清除自定义，刷新缓存）
' ======================
Public Sub ReAnalyzeSingleFile(ByVal FullPath As String)
If Not m_dictOrigOrient.Exists(FullPath) Then Exit Sub
Dim info As New clsFileInfo
info.FullPath = FullPath
info.AnalyzeFile
' 更新原始属性
Dim orientText As String
Select Case info.Orientation
Case 1: orientText = "竖向"
Case 2: orientText = "横向"
Case Else: orientText = "未设"
End Select
m_dictOrigOrient(FullPath) = orientText
Dim sizeText As String
Select Case info.PaperSize
Case 8: sizeText = "A3"
Case 9: sizeText = "A4"
Case Else: sizeText = "未设"
End Select
m_dictOrigPaper(FullPath) = sizeText
Dim zoomText As String
If info.ZoomIsPercent And info.ZoomValue > 0 Then
zoomText = Format(info.ZoomValue, "0") & "%"
ElseIf info.ZoomIsPercent = False And info.ZoomValue = 0 Then
zoomText = "适配"
Else
zoomText = "未设"
End If
m_dictOrigZoom(FullPath) = zoomText
m_dictOrigSheetCount(FullPath) = info.sheetCount
m_dictOrigPageCount(FullPath) = info.pageCount
m_dictReadStatus(FullPath) = info.ReadStatus
' 更新修改时间
On Error Resume Next
m_dictFileModTime(FullPath) = FileDateTime(FullPath)
On Error GoTo 0
' 刷新缓存
BuildFileCache FullPath
If info.ReadStatus = "成功" Then
LogToForm "重新分析文件：" & info.fileName & " → " & orientText & sizeText & "/" & zoomText
Else
LogToForm "重新分析失败：" & info.fileName & " → " & info.ReadStatus
End If
End Sub
' ======================
' 批量设置页面方向/纸张（覆盖所有文件的自定义）
' ======================
Public Sub BatchSetOrientPaper(ByVal orient As String, ByVal paper As String)
' 检查是否有文件未成功分析（可选提示，但此处可仅警告）
Dim i As Long, unanalyzed As String
For i = 0 To GetFileCount() - 1
Dim path As String
path = m_arrFilePaths(i)
If m_dictReadStatus.Exists(path) Then
If m_dictReadStatus(path) <> "成功" Then
unanalyzed = unanalyzed & Mid(path, InStrRev(path, "\") + 1) & vbCrLf
End If
End If
Next i
If unanalyzed <> "" Then
If MsgBox("以下文件未成功分析，批量设置可能显示异常：" & vbCrLf & unanalyzed & vbCrLf & "是否继续？", vbYesNo + vbExclamation, "提示") = vbNo Then
Exit Sub
End If
End If
For i = 0 To GetFileCount() - 1
m_dictCustomOrient(m_arrFilePaths(i)) = orient
m_dictCustomPaper(m_arrFilePaths(i)) = paper
Next i
End Sub
' ======================
' 批量设置缩放（覆盖所有文件的自定义）
' ======================
Public Sub BatchSetZoom(ByVal zoomText As String)
' 检查是否有文件未成功分析（同批量页面设置）
Dim i As Long, unanalyzed As String
For i = 0 To GetFileCount() - 1
Dim path As String
path = m_arrFilePaths(i)
If m_dictReadStatus.Exists(path) Then
If m_dictReadStatus(path) <> "成功" Then
unanalyzed = unanalyzed & Mid(path, InStrRev(path, "\") + 1) & vbCrLf
End If
End If
Next i
If unanalyzed <> "" Then
If MsgBox("以下文件未成功分析，批量设置可能显示异常：" & vbCrLf & unanalyzed & vbCrLf & "是否继续？", vbYesNo + vbExclamation, "提示") = vbNo Then
Exit Sub
End If
End If
For i = 0 To GetFileCount() - 1
m_dictCustomZoom(m_arrFilePaths(i)) = zoomText
Next i
End Sub
' ======================
' 清除所有自定义设置（恢复原文件）
' ======================
Public Sub ClearAllCustom()
m_dictCustomOrient.RemoveAll
m_dictCustomPaper.RemoveAll
m_dictCustomZoom.RemoveAll
End Sub
' ======================
' 单独设置方向/纸张
' ======================
Public Sub SetCustomOrientPaper(ByVal FullPath As String, ByVal orient As String, ByVal paper As String)
If Not m_dictOrigOrient.Exists(FullPath) Then Exit Sub
m_dictCustomOrient(FullPath) = orient
m_dictCustomPaper(FullPath) = paper
End Sub
' ======================
' 单独设置缩放
' ======================
Public Sub SetCustomZoom(ByVal FullPath As String, ByVal zoomText As String)
If Not m_dictOrigOrient.Exists(FullPath) Then Exit Sub
m_dictCustomZoom(FullPath) = zoomText
End Sub
' ======================
' 获取某个文件的最终属性（供转换使用）
' ======================
Private Sub GetFinalAttributes(ByVal FullPath As String, ByRef orient As String, ByRef paper As String, ByRef zoom As String)
If m_dictOrigOrient.Exists(FullPath) Then
orient = m_dictOrigOrient(FullPath)
paper = m_dictOrigPaper(FullPath)
zoom = m_dictOrigZoom(FullPath)
If m_dictCustomOrient.Exists(FullPath) And m_dictCustomOrient(FullPath) <> "" Then
orient = m_dictCustomOrient(FullPath)
End If
If m_dictCustomPaper.Exists(FullPath) And m_dictCustomPaper(FullPath) <> "" Then
paper = m_dictCustomPaper(FullPath)
End If
If m_dictCustomZoom.Exists(FullPath) And m_dictCustomZoom(FullPath) <> "" Then
zoom = m_dictCustomZoom(FullPath)
End If
Else
orient = "未设"
paper = "未设"
zoom = "未设"
End If
End Sub
' ======================
' 打印机管理函数（确保A3纸张正确输出）
' ======================
Private Function GetCurrentDefaultPrinter() As String
On Error Resume Next
Dim wshNet As Object
Set wshNet = CreateObject("WScript.Network")
GetCurrentDefaultPrinter = wshNet.DefaultPrinter
Set wshNet = Nothing
On Error GoTo 0
End Function
Private Function SetDefaultPrinter(ByVal printerName As String) As Boolean
On Error Resume Next
Dim wshNet As Object
Set wshNet = CreateObject("WScript.Network")
wshNet.SetDefaultPrinter printerName
SetDefaultPrinter = (Err.Number = 0)
Set wshNet = Nothing
On Error GoTo 0
End Function
Private Function PrinterExists(ByVal printerName As String) As Boolean
On Error Resume Next
Dim objWMIService As Object, colInstalledPrinters As Object, objPrinter As Object
Dim strComputer As String
strComputer = "."
Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
Set colInstalledPrinters = objWMIService.ExecQuery("Select * from Win32_Printer")
For Each objPrinter In colInstalledPrinters
If objPrinter.Name = printerName Then
PrinterExists = True
Exit For
End If
Next
Set objWMIService = Nothing
Set colInstalledPrinters = Nothing
On Error GoTo 0
End Function
' ======================
' 新增：获取打印机完整名称（带端口，用于 Application.ActivePrinter）
' ======================
Private Function GetPrinterFullName(ByVal printerName As String) As String
On Error Resume Next
Dim objWMIService As Object, colPrinters As Object, objPrinter As Object
Set objWMIService = GetObject("winmgmts:\\.\root\cimv2")
Set colPrinters = objWMIService.ExecQuery("Select * from Win32_Printer Where Name = '" & Replace(printerName, "'", "''") & "'")
For Each objPrinter In colPrinters
GetPrinterFullName = objPrinter.Name & " on " & objPrinter.PortName
Exit For
Next
On Error GoTo 0
End Function
' ======================
' 延迟回调入口（供窗体延迟调用）
' ======================
Public Sub DelayedBatchPageSetup()
If Not UserForm1 Is Nothing Then
UserForm1.ExecuteBatchPageSetup
End If
End Sub
Public Sub DelayedBatchZoom()
If Not UserForm1 Is Nothing Then
UserForm1.ExecuteBatchZoom
End If
End Sub
' ======================
' 批量转换PDF（整合打印机切换和自动重新分析）
' ======================
Public Sub ConvertAllFiles(ByVal CenterH As Boolean, ByVal CenterV As Boolean)
Dim total As Long, i As Long
total = GetFileCount()
If total = 0 Then
LogToForm "请先添加文件！"
Exit Sub
End If
' 检查未成功分析的文件
Dim unanalyzedList As String
For i = 0 To total - 1
Dim path As String
path = m_arrFilePaths(i)
If m_dictReadStatus.Exists(path) Then
If m_dictReadStatus(path) <> "成功" Then
unanalyzedList = unanalyzedList & Mid(path, InStrRev(path, "\") + 1) & vbCrLf
End If
End If
Next i
If unanalyzedList <> "" Then
If MsgBox("以下文件未成功分析：" & vbCrLf & unanalyzedList & vbCrLf & _
"是否继续转换？（未分析的文件将保留原页面设置，不影响转换）", _
vbYesNo + vbQuestion, "提示") = vbNo Then
Exit Sub
End If
End If
' 记录原打印机（分环境）
Dim originalActivePrinter As String
Dim originalDefaultPrinter As String
Dim switchedPrinter As String
Dim virtualPrinter As String
Dim fullPrinterName As String
' 查找虚拟打印机
virtualPrinter = ""
Dim candidates(0 To 2) As String
candidates(0) = "Microsoft Print to PDF"
candidates(1) = "Microsoft XPS Document Writer"
candidates(2) = "Adobe PDF"
Dim j As Integer
For j = 0 To 2
If PrinterExists(candidates(j)) Then
virtualPrinter = candidates(j)
Exit For
End If
Next j
If virtualPrinter <> "" Then
If GetAppType() = ExcelApp Then
' Excel 环境下使用 ActivePrinter
originalActivePrinter = Application.ActivePrinter
fullPrinterName = GetPrinterFullName(virtualPrinter)
If fullPrinterName <> "" Then
On Error Resume Next
Application.ActivePrinter = fullPrinterName
If Err.Number = 0 Then
switchedPrinter = virtualPrinter
LogToForm "已切换活动打印机为：" & fullPrinterName
Else
LogToForm "切换活动打印机失败：" & Err.Description
End If
On Error GoTo 0
Else
LogToForm "无法获取打印机完整名称，尝试系统默认打印机切换..."
originalDefaultPrinter = GetCurrentDefaultPrinter()
If originalDefaultPrinter <> "" Then
Call SetDefaultPrinter(virtualPrinter)
switchedPrinter = virtualPrinter
End If
End If
Else
' WPS 环境下使用系统默认打印机
originalDefaultPrinter = GetCurrentDefaultPrinter()
If originalDefaultPrinter <> "" Then
Call SetDefaultPrinter(virtualPrinter)
switchedPrinter = virtualPrinter
End If
End If
End If
If switchedPrinter = "" Then
LogToForm "未找到可用的虚拟打印机（Microsoft Print to PDF / XPS / Adobe PDF），A3尺寸可能无法正确应用"
End If
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim success As Long, fail As Long
success = 0: fail = 0
If gbEnablePageSetup Then
LogToForm "开始批量转换PDF（启用自定义页边距：上" & gfPageTop & "cm/下" & gfPageBottom & "cm/左" & gfPageLeft & "cm/右" & gfPageRight & "cm，页眉" & gfPageHeader & "cm/页脚" & gfPageFooter & "cm）..."
Else
LogToForm "开始批量转换PDF（保留原文件页边距/页眉页脚间距）..."
End If
' 记录隐藏工作表选项状态（只在转换时提示一次）
If gbIgnoreHiddenSheets Then
LogToForm "忽略隐藏工作表选项已启用，隐藏工作表将不参与转换"
Else
LogToForm "忽略隐藏工作表选项已禁用，隐藏工作表将参与转换（但PDF中不显示）"
End If
For i = 0 To total - 1
Dim FullPath As String, pdfPath As String
Dim wb As Workbook, ws As Worksheet
Dim pathStr As String, fileName As String
FullPath = m_arrFilePaths(i)
' --- 自动重新分析：检测文件是否被修改 ---
Dim curModTime As Variant
On Error Resume Next
curModTime = FileDateTime(FullPath)
If Err.Number = 0 Then
If m_dictFileModTime.Exists(FullPath) Then
If curModTime <> m_dictFileModTime(FullPath) Then
LogToForm "文件已修改，自动重新分析：" & FullPath
ReAnalyzeSingleFile FullPath
End If
End If
End If
On Error GoTo 0
pathStr = Left(FullPath, InStrRev(FullPath, "\"))
fileName = Mid(FullPath, InStrRev(FullPath, "\") + 1)
' 生成时间戳字符串，格式： [time=HH.MM.SS]
Dim timeStamp As String
timeStamp = "[time=" & Format(Now, "HH.MM.SS") & "]"
' 分离文件名和扩展名
Dim baseName As String, ext As String
If InStr(fileName, ".") > 0 Then
baseName = Left(fileName, InStrRev(fileName, ".") - 1)
ext = Mid(fileName, InStrRev(fileName, "."))
Else
baseName = fileName
ext = ""
End If
' 新文件名 = 原基础名 + 时间戳 + .pdf
fileName = baseName & timeStamp & ".pdf"
pdfPath = pathStr & fileName
On Error Resume Next
Set wb = Workbooks.Open(FullPath, ReadOnly:=True, UpdateLinks:=0)
On Error GoTo 0
If wb Is Nothing Then
fail = fail + 1
LogToForm "打开失败：" & FullPath
GoTo NextFile
End If
' 智能打印区域优化（仅对有效工作表，使用缓存加速）
For Each ws In wb.Worksheets
' 根据选项决定是否处理隐藏工作表
If ws.Visible = xlSheetVisible Or Not gbIgnoreHiddenSheets Then
Call OptimizeWorksheetPrintAreaEx(ws, FullPath)
End If
Next ws
' 获取最终属性
Dim orientVal As String, sizeVal As String, zoomVal As String
Call GetFinalAttributes(FullPath, orientVal, sizeVal, zoomVal)
' 解析缩放
Dim scaleIndex As Integer
Dim zoomPercent As Single
scaleIndex = 0
zoomPercent = 0
If Right(zoomVal, 1) = "%" Then
Dim numStr As String
numStr = Left(zoomVal, Len(zoomVal) - 1)
If IsNumeric(numStr) Then zoomPercent = CSng(numStr)
Else
Select Case zoomVal
Case "整页": scaleIndex = 1
Case "整列": scaleIndex = 2
Case "整行": scaleIndex = 3
End Select
End If
' 应用到每个工作表
For Each ws In wb.Worksheets
' 根据选项决定是否处理隐藏工作表
If ws.Visible = xlSheetVisible Or Not gbIgnoreHiddenSheets Then
With ws.PageSetup
If zoomPercent > 0 Then
ApplyPageSettings ws, orientVal, sizeVal, 0, zoomPercent
Else
ApplyPageSettings ws, orientVal, sizeVal, scaleIndex
End If
If gbEnablePageSetup Then
.TopMargin = gfPageTop * CM_TO_POINT
.BottomMargin = gfPageBottom * CM_TO_POINT
.LeftMargin = gfPageLeft * CM_TO_POINT
.RightMargin = gfPageRight * CM_TO_POINT
.HeaderMargin = gfPageHeader * CM_TO_POINT
.FooterMargin = gfPageFooter * CM_TO_POINT
End If
.CenterHorizontally = CenterH
.CenterVertically = CenterV
End With
' 根据“保留页眉页脚”选项决定是否清除页眉页脚
If Not gbKeepHeaderFooter Then
With ws.PageSetup
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
End With
End If
' WPS下强制刷新
If GetAppType() = WPSApp Then
With ws.PageSetup
If .PrintArea <> "" Then
.PrintArea = .PrintArea
End If
End With
End If
End If
Next ws
On Error Resume Next
wb.ExportAsFixedFormat Type:=xlTypePDF, fileName:=pdfPath, Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
If Err = 0 Then
success = success + 1
LogToForm "转换成功：" & pdfPath
Else
fail = fail + 1
LogToForm "转换失败：" & FullPath & " - " & Err.Description
End If
On Error GoTo 0
wb.Close SaveChanges:=False
Set wb = Nothing
NextFile:
Next i
' 恢复原打印机
If GetAppType() = ExcelApp Then
If originalActivePrinter <> "" Then
On Error Resume Next
Application.ActivePrinter = originalActivePrinter
On Error GoTo 0
End If
Else
If originalDefaultPrinter <> "" And switchedPrinter <> "" Then
Call SetDefaultPrinter(originalDefaultPrinter)
End If
End If
Application.ScreenUpdating = True
Application.DisplayAlerts = True
LogToForm "转换完成，成功：" & success & "，失败：" & fail
MsgBox "转换完成！" & vbCrLf & "成功：" & success & " 个" & vbCrLf & "失败：" & fail & " 个" & vbCrLf & "提示：转换后的PDF文件保存在原文件所在文件夹", vbInformation
End Sub
' ======================
' 以下为辅助函数（私有）
' ======================
Private Sub ForceRefreshPageSetup(ws As Worksheet)
If GetAppType() = WPSApp Then
On Error Resume Next
With ws.PageSetup
If .PrintArea <> "" Then
.PrintArea = .PrintArea
End If
End With
On Error GoTo 0
End If
End Sub
' 应用页面设置（支持百分比缩放和适配模式，整页模式智能优化）
Private Sub ApplyPageSettings(ws As Worksheet, orientText As String, sizeText As String, scaleIndex As Integer, Optional zoomPercent As Single = 0)
On Error GoTo SafeExit
With ws.PageSetup
' 页面方向
If orientText <> "未设" Then
If orientText = "竖向" Then
.Orientation = 1
ElseIf orientText = "横向" Then
.Orientation = 2
End If
End If
' 纸张尺寸
If sizeText <> "未设" Then
If sizeText = "A3" Then
.PaperSize = 8
ElseIf sizeText = "A4" Then
.PaperSize = 9
End If
End If
' 打印缩放
If zoomPercent > 0 Then
.zoom = zoomPercent
ElseIf scaleIndex > 0 Then
On Error Resume Next
.zoom = False
Select Case scaleIndex
Case 1 ' 整页：先尝试100%，若超过一页再适配（智能优化）
' 保存当前设置，临时设置为100%
.zoom = 100
' 强制刷新分页
ForceRefreshPageSetup ws
DoEvents
' 计算当前页数
Dim hPages As Integer, vPages As Integer
hPages = 1
vPages = 1
On Error Resume Next
hPages = ws.HPageBreaks.Count + 1
vPages = ws.VPageBreaks.Count + 1
On Error GoTo 0
' 如果页数大于1，则使用适配模式
If hPages * vPages > 1 Then
.FitToPagesTall = 1
.FitToPagesWide = 1
Else
.zoom = 100 ' 保持100%
End If
Case 2
.FitToPagesWide = 1
.FitToPagesTall = 0
Case 3
.FitToPagesTall = 1
.FitToPagesWide = 0
End Select
On Error GoTo 0
End If
End With
ForceRefreshPageSetup ws
' 强制刷新页面设置（确保打印机切换后生效）
If GetAppType() = ExcelApp Then
On Error Resume Next
With ws.PageSetup
.PrintCommunication = False
.PrintCommunication = True
End With
On Error GoTo 0
End If
SafeExit:
End Sub
Private Function GetWorksheetPageCountEx(ws As Worksheet, ByVal scaleIndex As Integer) As Integer
Dim pages As Integer
pages = 0
If IsWorksheetEmpty(ws) Then
GetWorksheetPageCountEx = 0
Exit Function
End If
If ws.PageSetup.PrintArea = "" Then
GetWorksheetPageCountEx = 0
Exit Function
End If
If GetAppType() = WPSApp And scaleIndex = 1 Then
GetWorksheetPageCountEx = 1
Exit Function
End If
On Error Resume Next
Dim hPages As Integer, vPages As Integer
hPages = ws.HPageBreaks.Count + 1
vPages = ws.VPageBreaks.Count + 1
If Err.Number = 0 Then
pages = hPages * vPages
Else
pages = 1
Err.Clear
End If
On Error GoTo 0
GetWorksheetPageCountEx = pages
End Function
' ======================
' 使用缓存的优化打印区域设置
' ======================
Private Sub OptimizeWorksheetPrintAreaEx(ws As Worksheet, ByVal FullPath As String)
If Not gbEnableSmartPrint Then Exit Sub
' 始终从缓存获取打印区域（缓存由 AnalyzeAllFiles 构建）
If m_dictFileCache.Exists(FullPath) Then
Dim cacheInfo As Object
Set cacheInfo = m_dictFileCache(FullPath)
Dim sheetCache As Object
If cacheInfo.Exists("Sheets") Then
Dim sheetsDict As Object
Set sheetsDict = cacheInfo("Sheets")
If sheetsDict.Exists(ws.Name) Then
Set sheetCache = sheetsDict(ws.Name)
Dim finalArea As String
finalArea = GetFinalAreaFromCache(sheetCache)
If finalArea <> "" Then
ws.PageSetup.PrintArea = finalArea
If gbResetPageBreaks Then ws.ResetAllPageBreaks
Exit Sub
End If
End If
End If
End If
' 缓存不可用（例如未分析或新文件），回退到实时分析
On Error GoTo ErrorHandler
Dim used As Range
Set used = SafeGetUsedRange(ws)
If used Is Nothing Then Exit Sub
If Application.WorksheetFunction.CountA(used) = 0 Then
ws.PageSetup.PrintArea = ""
Exit Sub
End If
Dim smartRng As Range
Set smartRng = GetSmartRangeOptimized(used, ws)
If Not smartRng Is Nothing Then
ws.PageSetup.PrintArea = smartRng.Address
If gbResetPageBreaks Then ws.ResetAllPageBreaks
End If
Exit Sub
ErrorHandler:
' 出错时保持原打印区域不变
End Sub
' ======================
' 优化后的智能区域获取（替代原 GetSmartRange 系列）
' ======================
Private Function GetSmartRangeOptimized(rngToCheck As Range, ws As Worksheet) As Range
Dim used As Range
Set used = Intersect(rngToCheck, ws.UsedRange)
If used Is Nothing Then Exit Function
' 优先处理文本/公式模式（高效）
If gbIncludeTextNum Or gbIncludeFormula Then
Dim validCells As Range
If gbIncludeTextNum Then
Set validCells = SafeGetSpecialCells(used, xlCellTypeConstants)
End If
If gbIncludeFormula Then
Dim formulaCells As Range
Set formulaCells = SafeGetSpecialCells(used, xlCellTypeFormulas)
If Not validCells Is Nothing Then
Set validCells = Union(validCells, formulaCells)
Else
Set validCells = formulaCells
End If
End If
If Not validCells Is Nothing Then
' 处理多区域合并
Dim mergedRange As Range
Set mergedRange = MergeAreas(validCells, ws)
If gbAutoExcludeHidden Then
' 过滤隐藏行列
Set mergedRange = ExcludeHiddenRowsCols(mergedRange, ws)
End If
Set GetSmartRangeOptimized = mergedRange
Exit Function
End If
End If
' 边框/背景色模式：使用 SpecialCells(xlCellTypeAllFormatConditions) 加速
If gbIncludeBorder Or gbIncludeBgColor Then
Dim formatCells As Range
On Error Resume Next
Set formatCells = used.SpecialCells(xlCellTypeAllFormatConditions)
On Error GoTo 0
If Not formatCells Is Nothing Then
' 合并区域
Dim mergedFormat As Range
Set mergedFormat = MergeAreas(formatCells, ws)
' 根据选项过滤（若仅边框，需剔除无边框但有背景色的单元格？此处简化，因为 AllFormatConditions 包含背景色，用户若只勾选边框，可能多包含背景色单元格，但影响不大）
If gbIncludeBorder And Not gbIncludeBgColor Then
' 可选：进一步过滤掉只有背景色的单元格（但会增加开销，暂不实现）
End If
If gbAutoExcludeHidden Then
Set mergedFormat = ExcludeHiddenRowsCols(mergedFormat, ws)
End If
Set GetSmartRangeOptimized = mergedFormat
Exit Function
End If
' 如果 SpecialCells 失败（如 WPS），回退到 FindFormat 或双循环
If GetAppType() = WPSApp Then
Set GetSmartRangeOptimized = FindBorderCellsFallback(used, ws)
Exit Function
End If
End If
' 没有任何选项，返回 Nothing
Set GetSmartRangeOptimized = Nothing
End Function
' ======================
' 合并多区域为最小矩形
' ======================
Private Function MergeAreas(cells As Range, ws As Worksheet) As Range
Dim minRow As Long, maxRow As Long
Dim minCol As Long, maxCol As Long
Dim area As Range
minRow = 1000000: maxRow = 0
minCol = 1000000: maxCol = 0
For Each area In cells.areas
If area.Row < minRow Then minRow = area.Row
If area.Row + area.Rows.Count - 1 > maxRow Then maxRow = area.Row + area.Rows.Count - 1
If area.Column < minCol Then minCol = area.Column
If area.Column + area.Columns.Count - 1 > maxCol Then maxCol = area.Column + area.Columns.Count - 1
Next area
Set MergeAreas = ws.Range(ws.cells(minRow, minCol), ws.cells(maxRow, maxCol))
End Function
' ======================
' 剔除隐藏行和列（返回新的矩形区域）
' ======================
Private Function ExcludeHiddenRowsCols(rng As Range, ws As Worksheet) As Range
If rng Is Nothing Then Exit Function
Dim r As Long, c As Long
Dim firstRow As Long, lastRow As Long
Dim firstCol As Long, lastCol As Long
Dim found As Boolean
firstRow = 0: lastRow = 0: firstCol = 0: lastCol = 0
found = False
' 遍历行
For r = rng.Row To rng.Row + rng.Rows.Count - 1
If Not ws.Rows(r).Hidden Then
If Not found Then
firstRow = r
found = True
End If
lastRow = r
End If
Next r
If Not found Then Exit Function
found = False
For c = rng.Column To rng.Column + rng.Columns.Count - 1
If Not ws.Columns(c).Hidden Then
If Not found Then
firstCol = c
found = True
End If
lastCol = c
End If
Next c
If Not found Then Exit Function
Set ExcludeHiddenRowsCols = ws.Range(ws.cells(firstRow, firstCol), ws.cells(lastRow, lastCol))
End Function
' ======================
' WPS 下回退方案：使用 FindFormat 按边框查找
' ======================
Private Function FindBorderCellsFallback(rng As Range, ws As Worksheet) As Range
On Error GoTo ErrHandler
Dim borderCells As Range
Dim i As Integer
Dim borderTypes(1 To 4) As Long
borderTypes(1) = xlEdgeLeft: borderTypes(2) = xlEdgeTop
borderTypes(3) = xlEdgeRight: borderTypes(4) = xlEdgeBottom
' 保存原 FindFormat
Dim oldFindFormat As Variant
On Error Resume Next
oldFindFormat = Application.FindFormat
On Error GoTo ErrHandler
For i = 1 To 4
With Application.FindFormat
.Clear
.Borders(borderTypes(i)).LineStyle = xlContinuous
End With
Dim cell As Range
Set cell = rng.Find(What:="", After:=rng.cells(1), _
LookAt:=xlWhole, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, _
SearchFormat:=True)
Do While Not cell Is Nothing
If borderCells Is Nothing Then
Set borderCells = cell
Else
Set borderCells = Union(borderCells, cell)
End If
Set cell = rng.FindNext(cell)
Loop
Next i
' 恢复原 FindFormat
On Error Resume Next
Application.FindFormat = oldFindFormat
On Error GoTo 0
If Not borderCells Is Nothing Then
Dim merged As Range
Set merged = MergeAreas(borderCells, ws)
If gbAutoExcludeHidden Then
Set merged = ExcludeHiddenRowsCols(merged, ws)
End If
Set FindBorderCellsFallback = merged
End If
Exit Function
ErrHandler:
' 出错返回 Nothing
Set FindBorderCellsFallback = Nothing
End Function
' ======================
' 缓存构建函数：分析文件并存储各特征区域
' ======================
Private Sub BuildFileCache(ByVal FullPath As String)
Dim wb As Workbook
On Error GoTo OpenErr
Set wb = Workbooks.Open(FullPath, ReadOnly:=True, UpdateLinks:=0)
On Error GoTo 0
If wb Is Nothing Then Exit Sub
Dim fileCache As Object
Set fileCache = CreateObject("Scripting.Dictionary")
fileCache("LastModTime") = m_dictFileModTime(FullPath)
Dim sheetsDict As Object
Set sheetsDict = CreateObject("Scripting.Dictionary")
Dim ws As Worksheet
For Each ws In wb.Worksheets
' 根据选项决定是否处理隐藏工作表
If ws.Visible = xlSheetVisible Or Not gbIgnoreHiddenSheets Then
Dim sheetCache As Object
Set sheetCache = CreateObject("Scripting.Dictionary")
Dim used As Range
Set used = SafeGetUsedRange(ws)
If Not used Is Nothing And Application.WorksheetFunction.CountA(used) > 0 Then
' 获取整个 UsedRange 的最小矩形
sheetCache("FullUsedRange") = used.Address
' 获取文本/数字区域
Dim constCells As Range, formulaCells As Range, textNumCells As Range
Set constCells = SafeGetSpecialCells(used, xlCellTypeConstants)
Set formulaCells = SafeGetSpecialCells(used, xlCellTypeFormulas)
If Not constCells Is Nothing And Not formulaCells Is Nothing Then
Set textNumCells = Union(constCells, formulaCells)
ElseIf Not constCells Is Nothing Then
Set textNumCells = constCells
Else
Set textNumCells = formulaCells
End If
If Not textNumCells Is Nothing Then
Dim mergedTextNum As Range
Set mergedTextNum = MergeAreas(textNumCells, ws)
sheetCache("TextNumRange") = mergedTextNum.Address
Else
sheetCache("TextNumRange") = ""
End If
' 获取公式区域（单独）
If Not formulaCells Is Nothing Then
Dim mergedFormula As Range
Set mergedFormula = MergeAreas(formulaCells, ws)
sheetCache("FormulaRange") = mergedFormula.Address
Else
sheetCache("FormulaRange") = ""
End If
' 获取有格式的单元格（边框/背景色）
Dim formatCells As Range
On Error Resume Next
Set formatCells = used.SpecialCells(xlCellTypeAllFormatConditions)
On Error GoTo 0
If Not formatCells Is Nothing Then
Dim mergedFormat As Range
Set mergedFormat = MergeAreas(formatCells, ws)
sheetCache("FormatRange") = mergedFormat.Address
Else
sheetCache("FormatRange") = ""
End If
' 始终缓存剔除隐藏行列后的版本（无论分析时的选项如何）
Dim visibleUsed As Range
Set visibleUsed = ExcludeHiddenRowsCols(used, ws)
If Not visibleUsed Is Nothing Then sheetCache("FullUsedRangeVisible") = visibleUsed.Address
If Not textNumCells Is Nothing Then
Dim visibleTextNum As Range
Set visibleTextNum = ExcludeHiddenRowsCols(mergedTextNum, ws)
If Not visibleTextNum Is Nothing Then sheetCache("TextNumRangeVisible") = visibleTextNum.Address
End If
If Not formulaCells Is Nothing Then
Dim visibleFormula As Range
Set visibleFormula = ExcludeHiddenRowsCols(mergedFormula, ws)
If Not visibleFormula Is Nothing Then sheetCache("FormulaRangeVisible") = visibleFormula.Address
End If
If Not formatCells Is Nothing Then
Dim visibleFormat As Range
Set visibleFormat = ExcludeHiddenRowsCols(mergedFormat, ws)
If Not visibleFormat Is Nothing Then sheetCache("FormatRangeVisible") = visibleFormat.Address
End If
End If
' 使用 Set 将 sheetCache 对象存入 sheetsDict
Set sheetsDict(ws.Name) = sheetCache
End If
Next ws
' 使用 Set 将 sheetsDict 对象存入 fileCache
Set fileCache("Sheets") = sheetsDict
Set m_dictFileCache(FullPath) = fileCache
wb.Close SaveChanges:=False
Set wb = Nothing
Exit Sub
OpenErr:
' 打开失败，缓存为空
If Not wb Is Nothing Then
On Error Resume Next
wb.Close SaveChanges:=False
On Error GoTo 0
End If
Set wb = Nothing
End Sub
' ======================
' 从缓存中获取最终打印区域字符串（根据当前用户选项）
' ======================
Private Function GetFinalAreaFromCache(sheetCache As Object) As String
Dim areaKey As String
Dim useVisible As Boolean
useVisible = gbAutoExcludeHidden
' 根据选项优先级确定使用哪个缓存区域
If gbIncludeTextNum Or gbIncludeFormula Then
' 优先使用文本/数字区域
If gbIncludeTextNum And gbIncludeFormula Then
areaKey = "TextNumRange"
ElseIf gbIncludeTextNum Then
areaKey = "TextNumRange"
Else
areaKey = "FormulaRange"
End If
ElseIf gbIncludeBorder Or gbIncludeBgColor Then
' 使用格式区域
areaKey = "FormatRange"
Else
' 没有选项，返回空（不设置打印区域）
GetFinalAreaFromCache = ""
Exit Function
End If
If useVisible Then
areaKey = areaKey & "Visible"
End If
If sheetCache.Exists(areaKey) Then
GetFinalAreaFromCache = sheetCache(areaKey)
Else
' 如果请求可见版本但缓存中没有，尝试返回普通版本（降级）
Dim normalKey As String
If gbIncludeTextNum Or gbIncludeFormula Then
If gbIncludeTextNum And gbIncludeFormula Then
normalKey = "TextNumRange"
ElseIf gbIncludeTextNum Then
normalKey = "TextNumRange"
Else
normalKey = "FormulaRange"
End If
Else
normalKey = "FormatRange"
End If
If sheetCache.Exists(normalKey) Then
GetFinalAreaFromCache = sheetCache(normalKey)
Else
GetFinalAreaFromCache = ""
End If
End If
End Function
' ======================
' 刷新所有缓存（当用户更改设置时调用，可选）
' ======================
Public Sub RefreshAllCaches()
LogToForm "正在刷新缓存..."
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim i As Long, total As Long
total = GetFileCount()
For i = 0 To total - 1
BuildFileCache m_arrFilePaths(i)
' 每处理10个文件输出一次进度，避免日志过多
If (i + 1) Mod 10 = 0 Then
LogToForm "已刷新 " & (i + 1) & " / " & total & " 个文件"
DoEvents
End If
Next i
Application.ScreenUpdating = True
Application.DisplayAlerts = True
LogToForm "缓存刷新完成"
End Sub
' ======================
' 清空所有缓存（强制重新分析）
' ======================
Public Sub ClearAllCaches()
m_dictFileCache.RemoveAll
LogToForm "所有缓存已清空"
End Sub
' ======================
' 清空所有缓存（静默模式，不输出日志）
' ======================
Public Sub ClearAllCachesSilent()
m_dictFileCache.RemoveAll
End Sub
[复制链接]
发表于 2026-4-2 09:13
|
发表于 2026-4-2 09:25
