VBA đếm trang PDF (Duyệt file từ folder and Subfolder) + phân loại trang A3 và A4 ?

[Lê Tuấn Anh 123456]

Chào mọi người,
Mình có 2 nguồn code về đếm trang PDF như sau:
1) VBA đếm trang PDF (folder and Subfolder) --> chỉ đếm trang tổng
Attribute VB_Name = "Module1"
Sub Test()
Dim I As Long
Dim xRg As Range
Dim xStr As String
Dim xFd As FileDialog
Dim xFdItem As Variant
Dim xFileName As String
Dim xFileNum As Long
Dim RegExp As Object
Set xFd = Application.FileDialog(msoFileDialogFolderPicker)
If xFd.Show = -1 Then
xFdItem = xFd.SelectedItems(1) & Application.PathSeparator
Set xRg = Range("A1")
Range("A:B").ClearContents
Range("A1:B1").Font.Bold = True
xRg = "File Name"
xRg.Offset(0, 1) = "Pages"
xRg.Offset(0, 2) = "Path"
xRg.Offset(0, 3) = "Size(b)"
I = 2
Call SunTest(xFdItem, I)
End If
End Sub

Sub SunTest(xFdItem As Variant, I As Long)
Dim xRg As Range
Dim xStr As String
Dim xFd As FileDialog
Dim xFileName As String
Dim xFileNum As Long
Dim RegExp As Object
Dim xF As Object
Dim xSF As Object
Dim xFso As Object
xFileName = Dir(xFdItem & "*.pdf", vbDirectory)
xStr = ""
Do While xFileName <> ""
Cells(I, 1) = xFileName
Set RegExp = CreateObject("VBscript.RegExp")
RegExp.Global = True
RegExp.Pattern = "/Type\s*/Page[^s]"
xFileNum = FreeFile
Open (xFdItem & xFileName) For Binary As #xFileNum
xStr = Space(LOF(xFileNum))
Get #xFileNum, , xStr
Close #xFileNum
Cells(I, 2) = RegExp.Execute(xStr).Count
Cells(I, 3) = xFdItem & xFileName
Cells(I, 4) = FileLen(xFdItem & xFileName)
I = I + 1
xFileName = Dir
Loop
Columns("A:B").AutoFit
Set xFso = CreateObject("Scripting.FileSystemObject")
Set xF = xFso.GetFolder(xFdItem)
For Each xSF In xF.SubFolders
Call SunTest(xSF.Path & "\", I)
Next
End Sub

2) Đếm trang A3 và A4 --> Tuy nhiên code này chỉ hoạt động khi copy file excel chứa VBD vào thư mục chứa file PDF, không hoạt động khi có subfolder.
Attribute VB_Name = "Module1"
Option Explicit
Public PDFDoc As AcroPDDoc, PDFPage As Object, A3&, A4&

Sub Main()
Dim fso As FileSystemObject, fld As Folder, fil As File, s$, i&, Arr()
Set fso = New FileSystemObject
Set PDFDoc = New AcroPDDoc
Set fld = fso.GetFolder(ThisWorkbook.Path)
ReDim Arr(1 To 1000, 1 To 3)
For Each fil In fld.Files
s = fil.Name
If Right(s, 4) = ".pdf" Then
CountPagesPDF (ThisWorkbook.Path & "\" & s)
i = i + 1
Arr(i, 1) = s
Arr(i, 2) = A3
Arr(i, 3) = A4
End If
Next
Range("A2:C" & Cells.Rows.Count).Clear
Range("A2:C" & (i + 1)) = Arr
Set PDFPage = Nothing
Set PDFDoc = Nothing
Set fso = Nothing
End Sub

Sub CountPagesPDF(FullFileName$)
Dim i&, n&, x, y
A3 = 0
A4 = 0
PDFDoc.Open (FullFileName)
n = PDFDoc.GetNumPages
For i = 0 To n - 1
Set PDFPage = PDFDoc.AcquirePage(i)
x = PDFPage.GetSize().x
y = PDFPage.GetSize().y
If x + y > 1500 Then A3 = A3 + 1 Else A4 = A4 + 1
Next
PDFDoc.Close
End Sub

Nhờ các cao nhân ghép 2 thứ này lại để vừa đếm trang A3 và A4 file PDF từ folder và subfoler giúp mình với !

 

[befaint]

If x + y > 1500 Then A3 = A3 + 1 Else A4 = A4 + 1

Code này đâu có đúng. Có rất nhiều khổ giấy thỏa mãn cái đó, ví dụ khổ giấy Letter, A5, B5...

 

[Lê Tuấn Anh 123456]

Code đó mình cũng tham khảo từ diễn đàn, mình đã test thử thì kết quả khá chính xác với A3 và A4, bạn giúp mình sửa chính xác lại đoạn đó với !