20171024xlVBA get ppt\word\pdf pages in bulk

Source: Internet
Author: User

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

Contact Us

The content source of this page is from Internet, which doesn't represent Alibaba Cloud's opinion; products and services mentioned on that page don't have any relationship with Alibaba Cloud. If the content of the page makes you feel confusing, please write us an email, we will handle the problem within 5 days after receiving your email.

If you find any instances of plagiarism from the community, please send an email to: info-contact@alibabacloud.com and provide relevant evidence. A staff member will contact you within 5 working days.

A Free Trial That Lets You Build Big!

Start building with 50+ products and up to 12 months usage for Elastic Compute Service

  • Sales Support

    1 on 1 presale consultation

  • After-Sales Support

    24/7 Technical Support 6 Free Tickets per Quarter Faster Response

  • Alibaba Cloud offers highly flexible support services tailored to meet your exact needs.