计算word文件打印页数 VBA实现_业界新闻

发布时间:2024-07-29 11:51

阅读量:0

场景复现

最近需要帮我弟打印高考资料，搜集完资料去网上打印，商家发出了这个计算页数的界面。我就好奇怎么实现的，计算的准不准，所以就动手自己用VBA代码实现了一下

环境说明

因为需要获取word文件的属性，所以需要引用work库。

实现原理

获取的是左下角页面的数量，然后把各个文件加起来。

计算当前文件夹下所有word文件页数总和

先实现计算当前文件夹下所有文件的，不会计算子文件夹。计算原理也很简单，直接要获取

Sub CountWordPagesInFolder()     Dim folderPath As String     Dim totalPages As Long     Dim doc As Object     Dim fileSystem As Object     Dim folder As Object     Dim file As Object      totalPages = 0          ' 设置文件夹路径   folderPath = "C:\Users\Administrator\Desktop\读取页数"      ' 创建FileSystemObject     Set fileSystem = CreateObject("Scripting.FileSystemObject")     Set folder = fileSystem.GetFolder(folderPath)        ' 遍历文件夹中的每个文件     For Each file In folder.Files         Debug.Print file.Name         If UCase(fileSystem.GetExtensionName(file.Name)) = "DOCX" Or _            UCase(fileSystem.GetExtensionName(file.Name)) = "DOC" Then             ' 打开Word文件             'Set doc = wordApp.Documents.Open(file.Path)                          ' 创建Word应用程序实例             Dim wordApp As Object             Set wordApp = CreateObject("Word.Application")             wordApp.Visible = False             Set doc = wordApp.Documents.Open(file.Path, ReadOnly:=True)                          ' 更新文档以确保准确计算页数             'doc.Repaginate                          'Debug.Print file.Path             ' 计算页数             'totalPages = totalPages + doc.ComputeStatistics(1) ' wdStatisticPages = 1             totalPages = totalPages + doc.ComputeStatistics(wdStatisticPages) ' wdStatisticPages = 1             ' 关闭文档             On Error Resume Next             doc.Close             If Err.Number <> 0 Then                 'Handle the error if any...                 Debug.Print "不正常正常关闭"             End If             On Error GoTo 0         End If     Next file      ' 关闭Word应用程序     wordApp.Quit      ' 输出总页数     MsgBox "Total pages in Word files: " & totalPages End Sub

利用递归计算当前文件夹所有work文件页面数量

folderPath 改成自己的文件夹就行了。

Sub CountWordPagesInFolder()     Dim folderPath As String     Dim totalPages As Long     Dim fileSystem As Object     Dim folder As Object     Dim wordApp As Object      totalPages = 0          ' 设置文件夹路径     folderPath = "E:\work\高考真题\打印参考答案"      ' 创建FileSystemObject     Set fileSystem = CreateObject("Scripting.FileSystemObject")     Set folder = fileSystem.GetFolder(folderPath)      ' 创建Word应用程序实例     Set wordApp = CreateObject("Word.Application")     wordApp.Visible = False      ' 遍历文件夹及其子文件夹中的所有文件     totalPages = TraverseFolders(folder, fileSystem, wordApp)      ' 关闭Word应用程序     wordApp.Quit      ' 释放对象     Set wordApp = Nothing     Set fileSystem = Nothing     Set folder = Nothing      ' 输出总页数     MsgBox "Total pages in Word files: " & totalPages End Sub  Function TraverseFolders(folder As Object, fileSystem As Object, wordApp As Object) As Long     Dim totalPages As Long     Dim file As Object     Dim subFolder As Object     Dim doc As Object      totalPages = 0          ' 遍历文件夹中的每个文件     For Each file In folder.Files         Debug.Print file         If UCase(fileSystem.GetExtensionName(file.Name)) = "DOCX" Or _            UCase(fileSystem.GetExtensionName(file.Name)) = "DOC" Then             ' 打开Word文件             On Error Resume Next             Set doc = wordApp.Documents.Open(file.Path, ReadOnly:=True)             If Err.Number <> 0 Then                 Debug.Print "无法打开文件: " & file.Path & " 错误信息: " & Err.Description                 Err.Clear                 On Error GoTo 0                 GoTo NextFile             End If             On Error GoTo 0                          ' 计算页数             totalPages = totalPages + doc.ComputeStatistics(wdStatisticPages)                          ' 关闭文档             'doc.Close SaveChanges:=False         End If NextFile:     Next file          ' 遍历子文件夹     For Each subFolder In folder.SubFolders         totalPages = totalPages + TraverseFolders(subFolder, fileSystem, wordApp)     Next subFolder      TraverseFolders = totalPages End Function

几个BUG

'doc.Close SaveChanges:=False

doc对象正常来说用完就应关闭的，但是关闭后打开第二个文件机会报错
Set doc = wordApp.Documents.Open(file.Path, ReadOnly:=True)

查询官网和GPT 都没给出很好的解释，然后我尝试关闭后每次重新创建一个wordApp对象读取文件信息，就不会报错。估计是关闭文件会释放这个对象资源或者其他，肯定会影响。
Set wordApp = CreateObject(“Word.Application”)
wordApp.Visible = False

Sub CountWordPagesInFolder()     Dim folderPath As String     Dim totalPages As Long     Dim doc As Object     Dim fileSystem As Object     Dim folder As Object     Dim file As Object      totalPages = 0          ' 设置文件夹路径   folderPath = "C:\Users\Administrator\Desktop\读取页数"      ' 创建FileSystemObject     Set fileSystem = CreateObject("Scripting.FileSystemObject")     Set folder = fileSystem.GetFolder(folderPath)        ' 遍历文件夹中的每个文件     For Each file In folder.Files         Debug.Print file.Name         If UCase(fileSystem.GetExtensionName(file.Name)) = "DOCX" Or _            UCase(fileSystem.GetExtensionName(file.Name)) = "DOC" Then             ' 打开Word文件             'Set doc = wordApp.Documents.Open(file.Path)                          ' 创建Word应用程序实例             Dim wordApp As Object             Set wordApp = CreateObject("Word.Application")             wordApp.Visible = False             Set doc = wordApp.Documents.Open(file.Path, ReadOnly:=True)                          ' 更新文档以确保准确计算页数             'doc.Repaginate                          'Debug.Print file.Path             ' 计算页数             'totalPages = totalPages + doc.ComputeStatistics(1) ' wdStatisticPages = 1             totalPages = totalPages + doc.ComputeStatistics(wdStatisticPages) ' wdStatisticPages = 1             ' 关闭文档             On Error Resume Next             doc.Close             If Err.Number <> 0 Then                 'Handle the error if any...                 Debug.Print "不正常正常关闭"             End If             On Error GoTo 0         End If     Next file      ' 关闭Word应用程序     wordApp.Quit      ' 输出总页数     MsgBox "Total pages in Word files: " & totalPages End Sub