夜雨聆风
' =============================================
' 第一个过程：选择单个文件夹，递归统计所有子文件夹内的PDF页数
' 修改点：不再直接遍历 Files，而是调用 ProcessFolder 递归处理
' =============================================
Sub 提取一个文件夹内的所有PDF文件页数()
' 需要系统安装 Adobe Acrobat 或支持 COM 的 Adobe Reader
Dim fso As Object, folderObj As Object
Dim acroApp As Object, acroPDDoc As Object
Dim targetFolder As String
Dim ws As Worksheet
Dim rowNum As Long
Dim pageCount As Long
Dim fileCount As Long, totalPages As Long
' 关闭屏幕更新，提升速度
Application.ScreenUpdating = False
' 让用户选择文件夹
With Application.fileDialog(msoFileDialogFolderPicker)
.Title = "请选择包含PDF文件的文件夹（将递归子文件夹）"
If .Show = -1 Then
targetFolder = .SelectedItems(1)
Else
MsgBox "未选择文件夹，操作取消。", vbExclamation
Exit Sub
End If
End With
' 创建或清空结果工作表
On Error Resume Next
Set ws = ActiveWorkbook.Worksheets("PDF页数统计")
If ws Is Nothing Then
Set ws = ActiveWorkbook.Worksheets.Add(After:=ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.Count))
ws.Name = "PDF页数统计"
Else
ws.Cells.Clear
End If
On Error GoTo 0
' 设置表头
With ws
.Range("A1") = "序号"
.Range("B1") = "文件名"
.Range("C1") = "页数"
.Range("D1") = "完整路径"
.Range("A1:D1").Font.Bold = True
.Columns("A:D").AutoFit
End With
rowNum = 2
' 创建FileSystemObject对象
Set fso = CreateObject("Scripting.FileSystemObject")
' 检查文件夹是否存在
If Not fso.FolderExists(targetFolder) Then
MsgBox "文件夹不存在：" & targetFolder, vbCritical
GoTo CleanUp
End If
Set folderObj = fso.GetFolder(targetFolder)
' 初始化Acrobat应用程序对象
On Error GoTo NoAcrobat
Set acroApp = CreateObject("AcroExch.App")
Set acroPDDoc = CreateObject("AcroExch.PDDoc")
On Error GoTo 0
fileCount = 0
totalPages = 0
' ----- 修改处：调用递归过程处理根文件夹及其所有子文件夹 -----
ProcessFolder folderObj, ws, fileCount, totalPages, rowNum, acroPDDoc, fso
' ------------------------------------------------------------
' 关闭Acrobat对象
acroPDDoc.Close
Set acroPDDoc = Nothing
acroApp.Exit
Set acroApp = Nothing
' 显示统计信息
MsgBox "统计完成！共处理 " & fileCount & " 个PDF文件，总页数： " & totalPages & " 页。", vbInformation
CleanUp:
Application.ScreenUpdating = True
Exit Sub
NoAcrobat:
MsgBox "系统中未找到Adobe Acrobat/Reader的COM组件。" & vbCrLf & _
"请确保已安装Adobe Acrobat（专业版/标准版）或支持COM的Acrobat Reader。", vbCritical
Application.ScreenUpdating = True
End Sub
' =============================================
' 第二个过程：允许选择多个文件夹，递归统计所有子文件夹内的PDF页数
' （无需修改，已支持多级文件夹）
' =============================================
Sub CountPDFPagesInMultiFolders()
' 需要系统安装 Adobe Acrobat 或支持 COM 的 Adobe Reader
Dim fso As Object, folderObj As Object
Dim acroApp As Object, acroPDDoc As Object
Dim folderPaths As Collection
Dim selectedPath As Variant
Dim ws As Worksheet
Dim rowNum As Long
Dim fileCount As Long, totalPages As Long
Dim continueAdd As VbMsgBoxResult
Application.ScreenUpdating = False
Set folderPaths = New Collection
Do
With Application.fileDialog(msoFileDialogFolderPicker)
.Title = "请选择一个文件夹（可多次添加）"
If .Show = -1 Then
selectedPath = .SelectedItems(1)
On Error Resume Next
folderPaths.Add selectedPath, CStr(selectedPath)
If Err.Number <> 0 Then
MsgBox "该文件夹已添加，请勿重复。", vbExclamation
End If
On Error GoTo 0
continueAdd = MsgBox("已添加：" & selectedPath & vbCrLf & "是否继续添加其他文件夹？", vbYesNo + vbQuestion, "继续添加？")
If continueAdd = vbNo Then Exit Do
Else
If folderPaths.Count > 0 Then
Exit Do
Else
MsgBox "未选择任何文件夹，操作取消。", vbExclamation
GoTo CleanUp
End If
End If
End With
Loop
' 创建或清空结果工作表
On Error Resume Next
Set ws = ActiveWorkbook.Worksheets("PDF页数统计")
If ws Is Nothing Then
Set ws = ActiveWorkbook.Worksheets.Add(After:=ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.Count))
ws.Name = "PDF页数统计"
Else
ws.Cells.Clear
End If
On Error GoTo 0
With ws
.Range("A1") = "序号"
.Range("B1") = "文件名"
.Range("C1") = "页数"
.Range("D1") = "完整路径"
.Range("A1:D1").Font.Bold = True
.Columns("A:D").AutoFit
End With
rowNum = 2
Set fso = CreateObject("Scripting.FileSystemObject")
On Error GoTo NoAcrobat
Set acroApp = CreateObject("AcroExch.App")
Set acroPDDoc = CreateObject("AcroExch.PDDoc")
On Error GoTo 0
fileCount = 0
totalPages = 0
For Each selectedPath In folderPaths
If fso.FolderExists(selectedPath) Then
ProcessFolder fso.GetFolder(selectedPath), ws, fileCount, totalPages, rowNum, acroPDDoc, fso
Else
MsgBox "路径不存在：" & selectedPath, vbExclamation
End If
Next selectedPath
acroPDDoc.Close
Set acroPDDoc = Nothing
acroApp.Exit
Set acroApp = Nothing
MsgBox "统计完成！共处理 " & fileCount & " 个PDF文件，总页数： " & totalPages & " 页。", vbInformation
CleanUp:
Application.ScreenUpdating = True
Exit Sub
NoAcrobat:
MsgBox "系统中未找到Adobe Acrobat/Reader的COM组件。" & vbCrLf & _
"请确保已安装Adobe Acrobat（专业版/标准版）或支持COM的Acrobat Reader。", vbCritical
Application.ScreenUpdating = True
End Sub
' =============================================
' 递归处理文件夹及其子文件夹（被两个过程共用）
' =============================================
Private Sub ProcessFolder(ByVal folderObj As Object, ByRef ws As Worksheet, _
ByRef fileCount As Long, ByRef totalPages As Long, _
ByRef rowNum As Long, ByRef acroPDDoc As Object, _
ByRef fso As Object)
Dim subFolder As Object, fileObj As Object
Dim pageCount As Long
' 处理当前文件夹中的PDF文件
For Each fileObj In folderObj.Files
If LCase(fso.GetExtensionName(fileObj.Name)) = "pdf" Then
fileCount = fileCount + 1
On Error Resume Next
acroPDDoc.Open (fileObj.Path)
If Err.Number <> 0 Then
pageCount = -1
Err.Clear
Else
pageCount = acroPDDoc.GetNumPages()
acroPDDoc.Close
End If
On Error GoTo 0
ws.Cells(rowNum, 1) = fileCount
ws.Cells(rowNum, 2) = fileObj.Name
If pageCount >= 0 Then
ws.Cells(rowNum, 3) = pageCount
totalPages = totalPages + pageCount
Else
ws.Cells(rowNum, 3) = "无法打开"
End If
ws.Cells(rowNum, 4) = fileObj.Path
rowNum = rowNum + 1
End If
Next fileObj
' 递归处理所有子文件夹
For Each subFolder In folderObj.SubFolders
ProcessFolder subFolder, ws, fileCount, totalPages, rowNum, acroPDDoc, fso
Next subFolder
End Sub
