VBA批量统计PDF页数的问题

指南龟

VBA统计PDF页数.rar (208.94 KB, 下载次数: 341)

2014-6-23 15:50 上传

点击文件名下载附件

各位大神，本人是个VBA菜鸟，混迹EH有一段时间，在这里收获良多，大大提升了工作效率，一直十分感激。最近因为工作需要，要对近三千份的PDF文件的页数进行计算，录入在EXCEL表格中输出对应的页数。手动点开查看太崩溃了，网上搜索了一下，之前已经有高人对这个问题进行了解答，但貌似只能针对部分较低版本的PDF文件，对较高版本的没辙。求助各位大神看看能不能做些修改，是下面的代码也能用到较高版本的PDF文件上，并且可以把统计结果录入到EXCEL表格中？？感激不尽~~~

PS 附件中包括需要输出的EXCEL格式，成功和不成功计算的PDF文件信息截图。

指南龟

太急了， 忘记贴上代码

1. Sub 按钮1_Click()
   
2.   Dim FileName As String
   
3. Dim Match, Str$, P%
   
4.   FileName = Application.GetOpenFilename("PDF文件(*.PDF),*.PDF")
   
5. With CreateObject("scripting.filesystemobject").opentextfile(FileName)
   
6.     Str = .readall
   
7.     .Close
   
8. End With
   
9. P = 0
   
10. With CreateObject("vbscript.regexp")
    
11.     .Global = True
    
12.     .MultiLine = True
    
13.     .Pattern = "\/Count ([\d]+)"
    
14.     If .test(Str) Then
    
15.         For Each Match In .Execute(Str)
    
16.             If Val(Match.submatches(0)) > P Then P = Val(Match.submatches(0))
    
17.         Next Match
    
18.     End If
    
19. End With
    
20. MsgBox (P)
    
21. End Sub

复制代码

指南龟

帖子沉得好快，自己顶顶~希望能吸引大神解答~~

dreamland_01

学习了，从网上摘录了一段，稍作修改，请参考下：
Sub pdfpage()
    Dim AcroApp As Acrobat.CAcroApp
    Dim numPages As Integer
    Dim PD1 As Acrobat.CAcroPDDoc
      
    Set AcroApp = CreateObject("AcroExch.App")
    Set PD1 = CreateObject("AcroExch.PDDoc")
      
    Dim mydialog As FileDialog
    Dim i As Integer, sFile As String
   
    Set mydialog = Application.FileDialog(msoFileDialogFilePicker)
   
    With mydialog
        .Filters.Clear '清除所有文件筛选器中的项目
        .Filters.Add "所有PDF文件", "*.pdf", 1 '增加筛选器的项目为所有pdf文件
        .AllowMultiSelect = True '允许多项选择
        .Show
        If .SelectedItems.Count = 0 Then
            MsgBox "没有选择任何文件！", vbExclamation + vbOKOnly, "提示"
            Exit Sub
        End If
        
        For i = 1 To .SelectedItems.Count
            sFile = .SelectedItems(i)
            Range("a" & i) = sFile
            PD1.Open (sFile)
            Range("b" & i) = PD1.GetNumPages()
            PD1.Close
        Next
        MsgBox "文件处理完毕！" & vbCrLf & vbCrLf & "共处理了 " & .SelectedItems.Count & " 个文件。", vbInformation + vbOKOnly, "提示"
    End With
    AcroApp.Exit
    Set AcroApp = Nothing
    Set PD1 = Nothing
End Sub

gugu_ma

dreamland_01 发表于 2015-8-20 14:31
学习了，从网上摘录了一段，稍作修改，请参考下：
Sub pdfpage()
    Dim AcroApp As Acrobat.CAcroApp

我这里也根据你们的做了一个合并..可是水平有限..不能实现同时处理多个文件

gugu_ma

Sub pdfcount()
Dim filename As String
Dim Match, Str$, P%
FileToOpen = Application.GetOpenFilename("PDF文件(*.PDF),*.PDF", , "Please select the files...", , True)

If IsArray(FileToOpen) = 0 Then
        'MsgBox "没有选择文件"
        MsgBox "No files are selected!"
        WS1.Unprotect
        GoTo ErrorHandler
End If

For i2 = 1 To UBound(FileToOpen)
       userfilename = FileToOpen(i2)
       With CreateObject("scripting.filesystemobject").opentextfile(FileToOpen(i2))
    Str = .readall
    .Close
End With
            P = 0
With CreateObject("vbscript.regexp")
    .Global = True
    .MultiLine = True
    .Pattern = "\/Count ([\d]+)"
    If .test(sstr) Then
        For Each Match In .Execute(sstr)
            If Val(Match.submatches(0)) > P Then P = Val(Match.submatches(0))
        Next Match
    End If
End With
MsgBox (P)
Cells(i2, 2).Value = P
Next i2
ErrorHandler:
End Sub
请各位老师帮忙完善下..谢谢

gugu_ma

gugu_ma 发表于 2016-3-29 16:05
Sub pdfcount()
Dim filename As String
Dim Match, Str$, P%

不知道是因为循环语句不对还是因为什么..

psq4ever

修改了一下，功能是：

cmd里dir命令输出目录下所有pdf文件名，放到A列将A列放PDF文件名，遍历整个A列，输出页数到C列。

------------------------

但是，不知道为什么代码在新建的xlsx能运行，而由于xlsx不能保存宏，关闭后宏消失。

保存为xls和xlsm后，再打开也无效。


总之要用的话就新建个xlsx然后粘贴下面的源码：


Sub DirPDF()
Dim filename As String
Dim Match, Str$, PP%, ii%

    ii = 1                          '行数初始化

    Do While Cells(ii, 1) <> ""     ' A列遍历Loop代码
        filename = Cells(ii, 1)
' ------------读取PDF页数核心代码---------------
        With CreateObject("scripting.filesystemobject").opentextfile(filename)
            Str = .readall
            .Close
        End With
        PP = 0
        With CreateObject("vbscript.regexp")
            .Global = True
            .MultiLine = True
            .Pattern = "\/Count ([\d]+)"
            If .test(Str) Then
                For Each Match In .Execute(Str)
                    If Val(Match.submatches(0)) > PP Then PP = Val(Match.submatches(0))
                Next Match
            End If
        End With
' ------------读取PDF页数核心代码---------------

    Cells(ii, 3) = PP   '--输出到C列
    ii = ii + 1         '行数递归
Loop
End Sub

psq4ever

psq4ever 发表于 2016-8-22 17:29
修改了一下，功能是：

cmd里dir命令输出目录下所有pdf文件名，放到A列将A列放PDF文件名，遍历整个A列， ...

终于改好了，原因是保存之后，opentextfile(filename)，只能获取到filename而没有目录，

于是先定义一下目录为宏xlsm所在目录，然后改成opentextfile(ipath & "\" & filename)

如下：
    ii = 1                          '行数初始化
    ipath = ThisWorkbook.Path
    Do While Cells(ii, 1) <> ""     ' A列遍历Loop代码
        filename = Cells(ii, 1)
' ------------读取PDF页数核心代码---------------
        With CreateObject("scripting.filesystemobject").opentextfile(ipath & "\" & filename)

wgfwad

怎么运行不了