20171024xlVBA get ppt\word\pdf pages in bulk

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 (msofiled Ialogfolderpicker). InitialFileName = Thisworkbook.path & "\". AllowMultiSelect = False. Title = "Select the folder where Excel workbooks are located" If. Show =-1 Then FolderPath =. SelectedItems (1) Else MsgBox "You have not selected any folders, this rollup is interrupted!" "Exit Sub end If End With if right (FolderPath, 1) <> Application.PathSeparator then Fol Derpath = folderpath & Application.PathSeparator FileNames = Fsogetfiles (FolderPath, "*pdf*|*doc*|*ppt*") in Dex = 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) & ") page" & 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) & "page)" & Extname on Error R Esume 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) & "page)" & 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:" & for Mat (Usedtime, "#0.0000 Seconds") End subprivate Function fsogetfiles (ByVal folderpath as String, ByVal Pattern as Strin  G, 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 Thi Sfolder = Fso.getfolder (folderpath) if Err.Number <> 0 then Exit Function If InStr (Pattern, "|") > 0 Th    En 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 = in                 Dex + 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 = NothingEnd    Functionprivate 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 (O Nematch.submatches (0)) End If Next Onematch End If End WithEnd Functionfunction getfil Epages (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 ' Project-Reference" Microsoft Shell controls and Automation "Dim Myshell as Shell32.shel L Dim Myshellfolder As Shell32.folder Dim FileName As String, Pos as Long, extname as String Set Myshell = New Sh Ell Pos = InStrRev (FilePath, "\") FileName = Left (FilePath, Pos-1) extname = Mid (FilePath, Pos + 1) Set Mysh Ellfolder = Myshell.namespace (Filename) If myshellfolder.getdetailsof (MyShellFolder.Items.Item (extname), Attrno) <> "Then Getfilepages = Mysh  Ellfolder.getdetailsof (MyShellFolder.Items.Item (extname), attrno) Else getfilepages = 0 End If Set Myshell = Nothing Set Myshellfolder = NothingEnd Function

　　

20171024xlVBA get ppt\word\pdf pages in bulk