asked on

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

Kimputer

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)

Nirvana

ASKER

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

Kimputer

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).

Nirvana

ASKER

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

Kimputer

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.

Nirvana

ASKER

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...

Kimputer

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.

Nirvana

ASKER

Sure mate. thank you.

ASKER CERTIFIED SOLUTION

Kimputer

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial

Nirvana

ASKER

I have followed the instruction however i am getting the below mentioned error

Nirvana

ASKER

there are few things that aren't working. however, thank you very much for your time and effort.

Kimputer

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

Nirvana

ASKER

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

Kimputer

You didn't install Acrobat (the full version, the paid version) properly, or you didn't add the reference yet.