merge pdf based on filenames

I am looking for a code which merges pdf files based on the first ten character of the file name

for example I have file as whizzbangs-1, whizzbangs-2, whizzbangs-3 all three files needs to be merged.

I have found the below code, it merges all the files from a folder, need a similar code but have to merge with file name

Sub Main() 
     
    Const DestFile As String = "MergedFile.pdf" ' <-- change to suit
     
    Dim MyPath As String, MyFiles As String 
    Dim a() As String, i As Long, f As String 
     
     ' Choose the folder or just replace that part by: MyPath = Range("E3")
    With Application.FileDialog(msoFileDialogFolderPicker) 
         '.InitialFileName = "C:\Temp\"
        .AllowMultiSelect = False 
        If .Show = False Then Exit Sub 
        MyPath = .SelectedItems(1) 
        DoEvents 
    End With 
     
     ' Populate the array a() by PDF file names
    If Right(MyPath, 1) <> "\" Then MyPath = MyPath & "\" 
    ReDim a(1 To 2 ^ 14) 
    f = Dir(MyPath & "*.pdf") 
    While Len(f) 
        If StrComp(f, DestFile, vbTextCompare) Then 
            i = i + 1 
            a(i) = f 
        End If 
        f = Dir() 
    Wend 
     
     ' Merge PDFs
    If i Then 
        ReDim Preserve a(1 To i) 
        MyFiles = Join(a, ",") 
        Application.StatusBar = "Merging, please wait ..." 
        Call MergePDFs(MyPath, MyFiles, DestFile) 
        Application.StatusBar = False 
    Else 
        MsgBox "No PDF files found in" & vbLf & MyPath, vbExclamation, "Canceled" 
    End If 
     
End Sub 
 
Sub MergePDFs(MyPath As String, MyFiles As String, Optional DestFile As String = "MergedFile.pdf") 
     ' ZVI:2013-08-27 http://www.vbaexpress.com/forum/showthread.php?47310-Need-code-to-merge-PDF-files-in-a-folder-using-adobe-acrobat-X
     ' Reference required: VBE - Tools - References - Acrobat
     
    Dim a As Variant, i As Long, n As Long, ni As Long, p As String 
    Dim AcroApp As New Acrobat.AcroApp, PartDocs() As Acrobat.CAcroPDDoc 
     
    If Right(MyPath, 1) = "\" Then p = MyPath Else p = MyPath & "\" 
    a = Split(MyFiles, ",") 
    ReDim PartDocs(0 To UBound(a)) 
     
    On Error GoTo exit_ 
    If Len(Dir(p & DestFile)) Then Kill p & DestFile 
    For i = 0 To UBound(a) 
         ' Check PDF file presence
        If Dir(p & Trim(a(i))) = "" Then 
            MsgBox "File not found" & vbLf & p & a(i), vbExclamation, "Canceled" 
            Exit For 
        End If 
         ' Open PDF document
        Set PartDocs(i) = CreateObject("AcroExch.PDDoc") 
        PartDocs(i).Open p & Trim(a(i)) 
        If i Then 
             ' Merge PDF to PartDocs(0) document
            ni = PartDocs(i).GetNumPages() 
            If Not PartDocs(0).InsertPages(n - 1, PartDocs(i), 0, ni, True) Then 
                MsgBox "Cannot insert pages of" & vbLf & p & a(i), vbExclamation, "Canceled" 
            End If 
             ' Calc the number of pages in the merged document
            n = n + ni 
             ' Release the memory
            PartDocs(i).Close 
            Set PartDocs(i) = Nothing 
        Else 
             ' Calc the number of pages in PartDocs(0) document
            n = PartDocs(0).GetNumPages() 
        End If 
    Next 
     
    If i > UBound(a) Then 
         ' Save the merged document to DestFile
        If Not PartDocs(0).Save(PDSaveFull, p & DestFile) Then 
            MsgBox "Cannot save the resulting document" & vbLf & p & DestFile, vbExclamation, "Canceled" 
        End If 
    End If 
     
exit_: 
     
     ' Inform about error/success
    If Err Then 
        MsgBox Err.Description, vbCritical, "Error #" & Err.Number 
    ElseIf i > UBound(a) Then 
        MsgBox "The resulting file is created:" & vbLf & p & DestFile, vbInformation, "Done" 
    End If 
     
     ' Release the memory
    If Not PartDocs(0) Is Nothing Then PartDocs(0).Close 
    Set PartDocs(0) = Nothing 
     
     ' Quit Acrobat application
    AcroApp.Exit 
    Set AcroApp = Nothing 
     
End Sub 

Open in new window

NirvanamanagerAsked:
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

KimputerCommented:
Simplest way for now, is to move each file in the folder to its subfolder based on the 10 first chars, then process all subfolders with the same code you already have.
What I'm concerned about though is, the correct order of merging the files. I don't see any checks for alphabetical order. And even if there was, you need to check if there are more than 10 pages, if it's:

situation a:

whizzbangs-1
through
whizzbangs-10
through
whizzbangs-101 etc

or

situation b:

whizzbangs-001
through
whizzbangs-199

If situation a, some extensive extra coding needs to be done.

While you might not like the moving to each subfolder, it saves extensively on coding (probably a factor of 2, also in time spent on it)
0
NirvanamanagerAuthor Commented:
Thank you for the quick reply i will not have more than ten pages for each file the merge should happen based on the sequence of the file say

whizzbangs-001
whizzbangs-002
through
whizzbangs-010

to move every file to new folder will take time as i will have hundreds of files
0
KimputerCommented:
No, the moving is done with code, and since moving takes less time on a local system (or even Windows Network), even with a few hundreds of files, and hundreds of folders, it won't take much time (estimate 30 seconds). Windows is quite efficient with moving (it doesn't really touch the file, only the file location tables).
0
Ultimate Tool Kit for Technology Solution Provider

Broken down into practical pointers and step-by-step instructions, the IT Service Excellence Tool Kit delivers expert advice for technology solution providers. Get your free copy now.

NirvanamanagerAuthor Commented:
wow if that can be done that would be great..so you mean to say a folder would be created based on the file name and i use the same code that you used above to merge files and also could you please update the code to select multiple folders?

can you please provide the code to move files to folder
0
KimputerCommented:
First have this code execute (so it moves the pdf's into each subfolder):

Sub createsub()

    Dim MyPath As String, MyFiles As String
    
    With Application.FileDialog(msoFileDialogFolderPicker)
         '.InitialFileName = "C:\Temp\"
        .AllowMultiSelect = False
        If .Show = False Then Exit Sub
        MyPath = .SelectedItems(1)
        DoEvents
    End With
    
    If Right(MyPath, 1) <> "\" Then MyPath = MyPath & "\"
    f = Dir(MyPath & "*.pdf")
    While Len(f)
        If FolderExists(MyPath & Left(f, 10)) Then
           MoveFile MyPath & f, MyPath & Left(f, 10) & "\" & f
        Else
            CreateFolder (MyPath & Left(f, 10))
            MoveFile MyPath & f, MyPath & Left(f, 10) & "\" & f
        End If
        
        f = Dir()
    Wend

End Sub

Public Function FolderExists(strFullPath As String) As Boolean
'Author       : Ken Puls (www.excelguru.ca)
'Macro Purpose: Check if a file or folder exists
    On Error GoTo EarlyExit
    Set fs = CreateObject("Scripting.FileSystemObject")
    FolderExists = fs.FolderExists(strFullPath)
    Set fs = Nothing
EarlyExit:
    On Error GoTo 0
End Function

Public Sub CreateFolder(strFullPath As String)
    On Error GoTo EarlyExit
    Set fs = CreateObject("Scripting.FileSystemObject")
    fs.CreateFolder (strFullPath)
    Set fs = Nothing
EarlyExit:
    On Error GoTo 0
End Sub

Public Sub MoveFile(file As String, strFullPath As String)
    On Error GoTo EarlyExit
    Name file As strFullPath
EarlyExit:
    On Error GoTo 0
End Sub

Open in new window


Please note, shorter files names might give you problems.

Also, after this code, you should run your original code, but it needs one change too (it needs to go through all the sub folders instead of the main folder).
Then, there's still the alphabetical order, which I don't think was implemented yet. So still needs work!

Let me know if you still need help, or the additional steps can be done by yourself.
0
NirvanamanagerAuthor Commented:
Thank you very much.. sir this is brilliant. the only change in the original code, if i can select multiple folders rather than one folder ata a time.. that would be a massive time saving...
0
KimputerCommented:
I'll change the original code later. No choice of multiple folders though, as that doesn't make sense with the script I already wrote. As that script had I've source folder and moved everything to sub folders, the original script should adjust to that too. One source folder, and scour all the sub folders (instead of a choice for multiple).

After that, you have to test again, then check if pages are merged in correct order or not.
0
NirvanamanagerAuthor Commented:
Sure mate. thank you.
0
KimputerCommented:
Here's the code to replace the original code. You only select one source folder, and it will process the sub folders (each merged PDF will have the same name, IN that subfolder).
This is where my testing ends, as I don't have Acrobat to test with. Therefore there is some conjecture in this code, which I hope you can debug yourself:

Sub Main()
     
        
    Dim MyPath As String, MyFiles As String
  
     
     ' Choose the folder or just replace that part by: MyPath = Range("E3")
    With Application.FileDialog(msoFileDialogFolderPicker)
         '.InitialFileName = "C:\Temp\"
        .AllowMultiSelect = False
        If .Show = False Then Exit Sub
        MyPath = .SelectedItems(1)
        DoEvents
    End With
     
     Set FSO = CreateObject("Scripting.FileSystemObject")
Set fld = FSO.getfolder(MyPath)
         
     
For Each subfolder In fld.subfolders
    processsubfolder (subfolder)
Next

         Set FSO = Nothing
	Set fld = Nothing

End Sub
 
 Sub processsubfolder(MyPath As String)
    Dim a() As String, i As Long, f As String
     Const DestFile As String = "MergedFile.pdf"
      ' Populate the array a() by PDF file names
    If Right(MyPath, 1) <> "\" Then MyPath = MyPath & "\"
    ReDim a(1 To 2 ^ 14)
    f = Dir(MyPath & "*.pdf")
    While Len(f)
        If StrComp(f, DestFile, vbTextCompare) Then
            i = i + 1
            a(i) = f
        End If
        f = Dir()
    Wend
     
     ' Merge PDFs
    If i Then
        ReDim Preserve a(1 To i)
        MyFiles = Join(a, ",")
        Application.StatusBar = "Merging, please wait ..."
        Call MergePDFs(MyPath, MyFiles, DestFile)
        Application.StatusBar = False
    Else
        MsgBox "No PDF files found in" & vbLf & MyPath, vbExclamation, "Canceled"
    End If
 
 
 End Sub
    
Sub MergePDFs(MyPath As String, MyFiles As String, Optional DestFile As String = "MergedFile.pdf")
     ' ZVI:2013-08-27 http://www.vbaexpress.com/forum/showthread.php?47310-Need-code-to-merge-PDF-files-in-a-folder-using-adobe-acrobat-X
     ' Reference required: VBE - Tools - References - Acrobat
     
    Dim a As Variant, i As Long, n As Long, ni As Long, p As String
    Dim AcroApp As New Acrobat.AcroApp, PartDocs() As Acrobat.CAcroPDDoc
     
    If Right(MyPath, 1) = "\" Then p = MyPath Else p = MyPath & "\"
    a = Split(MyFiles, ",")
    ReDim PartDocs(0 To UBound(a))
     
    On Error GoTo exit_
    If Len(Dir(p & DestFile)) Then Kill p & DestFile
    For i = 0 To UBound(a)
         ' Check PDF file presence
        If Dir(p & Trim(a(i))) = "" Then
            MsgBox "File not found" & vbLf & p & a(i), vbExclamation, "Canceled"
            Exit For
        End If
         ' Open PDF document
        Set PartDocs(i) = CreateObject("AcroExch.PDDoc")
        PartDocs(i).Open p & Trim(a(i))
        If i Then
             ' Merge PDF to PartDocs(0) document
            ni = PartDocs(i).GetNumPages()
            If Not PartDocs(0).InsertPages(n - 1, PartDocs(i), 0, ni, True) Then
                MsgBox "Cannot insert pages of" & vbLf & p & a(i), vbExclamation, "Canceled"
            End If
             ' Calc the number of pages in the merged document
            n = n + ni
             ' Release the memory
            PartDocs(i).Close
            Set PartDocs(i) = Nothing
        Else
             ' Calc the number of pages in PartDocs(0) document
            n = PartDocs(0).GetNumPages()
        End If
    Next
     
    If i > UBound(a) Then
         ' Save the merged document to DestFile
        If Not PartDocs(0).Save(PDSaveFull, p & DestFile) Then
            MsgBox "Cannot save the resulting document" & vbLf & p & DestFile, vbExclamation, "Canceled"
        End If
    End If
     
exit_:
     
     ' Inform about error/success
    If Err Then
        MsgBox Err.Description, vbCritical, "Error #" & Err.Number
    ElseIf i > UBound(a) Then
        MsgBox "The resulting file is created:" & vbLf & p & DestFile, vbInformation, "Done"
    End If
     
     ' Release the memory
    If Not PartDocs(0) Is Nothing Then PartDocs(0).Close
    Set PartDocs(0) = Nothing
     
     ' Quit Acrobat application
    AcroApp.Exit
    Set AcroApp = Nothing
     
End Sub

Open in new window


And the sorting might still need to be coded (if pages are not in correct order after your testing). Don't forget, run this code on the same source folder, AFTER you've run the previous code I wrote (which moved the files to each subfolder)
0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
NirvanamanagerAuthor Commented:
I have followed the instruction however i am getting the below mentioned error
errorerror2
0
NirvanamanagerAuthor Commented:
there are few things that aren't working. however, thank you very much for your time and effort.
0
KimputerCommented:
Find:

Dim a() As String, i As Long, f As String

Replace:

Dim a() As String, i As Long, f As String, MyFiles As String
1
NirvanamanagerAuthor Commented:
I am getting a "run-time error 429" when i am executing it what do i need to change in the code

i could not understand the below link

https://support.microsoft.com/en-us/kb/828550
0
KimputerCommented:
You didn't install Acrobat (the full version, the paid version) properly, or you didn't add the reference yet.
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Visual Basic Classic

From novice to tech pro — start learning today.

Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.