20171024xlVBA批量获取PPTWORDPDF页数

Public Sub ModifyFileNames()
    Dim FolderPath As String
    Dim FileNames As Variant

    Dim dotPos As Long
    Dim ExtName As String
    Dim RealName As String
    Dim NewFile() As String
    ReDim NewFile(1 To 1) As String
    Dim Index As Long
    
    Dim StartTime As Variant
    Dim UsedTime As Variant
    StartTime = VBA.Timer
    
    

    'Set ppApp = CreateObject("Powerpoint.Application")
  
    
    
    
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = ThisWorkbook.Path & ""
        .AllowMultiSelect = False
        .Title = "请选取Excel工作簿所在文件夹"
        If .Show = -1 Then
            FolderPath = .SelectedItems(1)
        Else
            MsgBox "您没有选中任何文件夹，本次汇总中断！"
            Exit Sub
        End If
    End With
    
    If Right(FolderPath, 1) <> Application.PathSeparator Then FolderPath = FolderPath & Application.PathSeparator
    
    FileNames = FsoGetFiles(FolderPath, "*PDF*|*DOC*|*PPT*")
    Index = 0
    For n = LBound(FileNames) To UBound(FileNames) Step 1
        Debug.Print FileNames(n)
        Index = Index + 1
        ReDim Preserve NewFile(1 To Index)
        FilePath = FileNames(n)
        If UCase(FileNames(n)) Like "*.PDF" Then
            'Debug.Print PdfPageCount(FilePath)
            dotPos = InStrRev(FilePath, ".")
            ExtName = Mid(FilePath, dotPos)
            Debug.Print ExtName
            RealName = Left(FilePath, dotPos - 1)
            NewPath = RealName & "(" & PdfPageCount(FilePath) & ")页" & ExtName
            On Error Resume Next
            Kill NewPath
            On Error GoTo 0
            VBA.FileCopy FilePath, NewPath
            NewFile(Index) = NewPath
            On Error Resume Next
            Kill FilePath
            On Error GoTo 0
        ElseIf UCase(FileNames(n)) Like "*.DOC*" Then
            'Debug.Print WordPageCount(FilePath)
            dotPos = InStrRev(FilePath, ".")
            ExtName = Mid(FilePath, dotPos)
            Debug.Print ExtName
            RealName = Left(FilePath, dotPos - 1)
            NewPath = RealName & "(" & GetFilePages(FilePath) & "页)" & ExtName
            On Error Resume Next
            Kill NewPath
            On Error GoTo 0
            VBA.FileCopy FilePath, NewPath
            NewFile(Index) = NewPath
            On Error Resume Next
            Kill FilePath
            On Error GoTo 0
        ElseIf UCase(FileNames(n)) Like "*.PPT*" Then
            'Debug.Print SlidePageCount(FilePath)
            dotPos = InStrRev(FilePath, ".")
            ExtName = Mid(FilePath, dotPos)
            Debug.Print ExtName
            RealName = Left(FilePath, dotPos - 1)
            NewPath = RealName & "(" & GetFilePages(FilePath) & "页)" & ExtName
            On Error Resume Next
            Kill NewPath
            On Error GoTo 0
            VBA.FileCopy FilePath, NewPath
            NewFile(Index) = NewPath
            On Error Resume Next
            Kill FilePath
            On Error GoTo 0
        End If
    Next n
    
    UsedTime = VBA.Timer - StartTime
    ' Debug.Print "UsedTime ：" & Format(UsedTime, "#0.0000 Seconds")
    MsgBox "UsedTime ：" & Format(UsedTime, "#0.0000 Seconds")
    
End Sub
Private Function FsoGetFiles(ByVal FolderPath As String, ByVal Pattern As String, Optional ComplementPattern As String = "") As String()
    Dim Arr() As String
    Dim FSO As Object
    Dim ThisFolder As Object
    Dim OneFile As Object
    Dim Pats As Variant
    
    ReDim Arr(1 To 1)
    Arr(1) = "None"
    Dim Index As Long
    Dim p As Long
    Index = 0
    Set FSO = CreateObject("Scripting.FileSystemObject")
    On Error GoTo ErrorExit
    Set ThisFolder = FSO.getfolder(FolderPath)
    If Err.Number <> 0 Then Exit Function
    
    If InStr(Pattern, "|") > 0 Then
        Pats = Split(Pattern, "|")
    Else
        ReDim Pats(1 To 1) As String
        Pats(1) = Pattern
    End If
    
    For Each OneFile In ThisFolder.Files
        For p = LBound(Pats) To UBound(Pats)
            
            If UCase(OneFile.Name) Like Pats(p) Then
                If Len(ComplementPattern) > 0 Then
                    If Not UCase(OneFile.Name) Like ComplementPattern Then
                        Index = Index + 1
                        ReDim Preserve Arr(1 To Index)
                        Arr(Index) = OneFile.Path '& OneFile.Name
                    End If
                Else
                    Index = Index + 1
                    ReDim Preserve Arr(1 To Index)
                    Arr(Index) = OneFile.Path '& OneFile.Name
                End If
                
                Exit For
            End If
            
        Next p
    Next OneFile
ErrorExit:
    FsoGetFiles = Arr
    Erase Arr
    Set FSO = Nothing
    Set ThisFolder = Nothing
    Set OneFile = Nothing
End Function
Private Function PdfPageCount(ByVal FilePath As String) As Long
    Debug.Print FilePath
    Dim OneMatch, mStr$
    PdfPageCount = 0
    With CreateObject("Scripting.FileSystemObject").OpenTextFile(FilePath)
        mStr = .readall
        .Close
    End With
    With CreateObject("VBScript.RegExp")
        .Global = True
        .MultiLine = True
        .Pattern = "/Count ([d]+)"
        If .TEST(mStr) Then
            For Each OneMatch In .Execute(mStr)
                If Val(OneMatch.submatches(0)) > PdfPageCount Then
                    PdfPageCount = Val(OneMatch.submatches(0))
                End If
            Next OneMatch
        End If
    End With
End Function
Function GetFilePages(ByVal FilePath As String) As Variant
    Dim AttrNo As Long
    Select Case True
    Case UCase(FilePath) Like "*.DOC*"
        AttrNo = 148
    Case UCase(FilePath) Like "*.PPT*"
        AttrNo = 149
    End Select
    '工程-引用 “microsoft shell controls and automation”
    Dim myShell As Shell32.Shell
    Dim myShellFolder As Shell32.Folder
    Dim FileName As String, Pos As Long, ExtName As String
    Set myShell = New Shell
    Pos = InStrRev(FilePath, "")
    FileName = Left(FilePath, Pos - 1)
    ExtName = Mid(FilePath, Pos + 1)
    Set myShellFolder = myShell.Namespace(FileName)
    If myShellFolder.GetDetailsOf(myShellFolder.Items.Item(ExtName), AttrNo) <> "" Then
        GetFilePages = myShellFolder.GetDetailsOf(myShellFolder.Items.Item(ExtName), AttrNo)
    Else
        GetFilePages = 0
    End If
    Set myShell = Nothing
    Set myShellFolder = Nothing
End Function