计算word文件打印页数 VBA实现

目录

场景复现

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

环境说明

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

实现原理

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

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

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

bash 复制代码
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 改成自己的文件夹就行了。

bash 复制代码
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

bash 复制代码
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

知道原因的大佬可以评论一下

计算结果

我计算了5025页,商家的软件只计算了 4699页!看来还是挺良心的。

顺藤摸瓜,我问了商家他们说是老板买软件计算的,这个是打印软件的官网https://www.nprint.cn/,这让我感觉到需求无处不在啊!

软件报价

后话

至于计算为什么不一样,我也联系和软件官方账号询问他们的计算算法是否有差异,目前还没回复。

相关推荐
掘根23 分钟前
【CMake】List
windows·microsoft·list
玩泥巴的2 小时前
.NET驾驭Word之力:COM组件二次开发全攻略之连接Word与创建你的第一个自动化文档
word·二次开发·com互操作
小琦QI3 小时前
关于电脑连接不到5g的WiFi时的一些解决办法
5g·microsoft·win
程序员东岸7 小时前
C语言入门指南:字符函数和字符串函数
c语言·笔记·学习·程序人生·算法
武子康14 小时前
AI-调查研究-76-具身智能 当机器人走进生活:具身智能对就业与社会结构的深远影响
人工智能·程序人生·ai·职场和发展·机器人·生活·具身智能
星空的资源小屋20 小时前
Digital Clock 4,一款免费的个性化桌面数字时钟
stm32·单片机·嵌入式硬件·电脑·excel
I'm a winner21 小时前
第七章:AI进阶之------输入与输出函数(一)
开发语言·人工智能·python·深度学习·神经网络·microsoft·机器学习
dyxal1 天前
linux系统安装wps
linux·运维·wps
过河卒_zh15667661 天前
9.13AI简报丨哈佛医学院开源AI模型,Genspark推出AI浏览器
人工智能·算法·microsoft·aigc·算法备案·生成合成类算法备案
揭老师高效办公1 天前
在Excel和WPS表格中批量删除数据区域的批注
excel·wps表格