Printing separate reports into one combined PDF using VBA? (1 Viewer)

Sub MergePDF()





    'Combined multiple PDF files into one
    'set a reference to Acrobat (Adobe Acrobat 7.0 Type Library)
    'http://www.khk.net/wordpress/2009/03/04/adobe-acrobat-and-vba-an-introduction/
    '30-JUL-2010
    
    'Added code to close the open pdf files (except for the final merged report)
    '09-Jun-2011
    
    'May need to see if file exists when this is run more than once.  Will add if needed
    
    Dim AcroApp As Acrobat.CAcroApp
    
    Dim Part1Document As Acrobat.CAcroPDDoc
    Dim Part2Document As Acrobat.CAcroPDDoc
    
    Dim numPages As Integer
    Dim pdfsrc As String
    Dim x As Integer
    Dim stMergename As String
    
    Set AcroApp = CreateObject("AcroExch.App")
    
    Set Part1Document = CreateObject("AcroExch.PDDoc")
    Set Part2Document = CreateObject("AcroExch.PDDoc")
         
    pdfsrc = "C:\Desktop\PrintFiles\Program_Summary_1.pdf"
     
    x = 2
    
    Part1Document.Open (pdfsrc)
    Part2Document.Open (Replace(pdfsrc, "1", x))
        
    Do While x < 6
        ' Insert the pages of Part2 after the end of Part1
        numPages = Part1Document.GetNumPages()
        
        If Part1Document.InsertPages(numPages - 1, Part2Document, 0, Part2Document.GetNumPages(), True) = False Then
            MsgBox "Cannot insert pages for " & (Replace(pdfsrc, "1", x)) & ".  See if it is on the disk.  If not, please recreate."
            MsgBox "Close all open Adobe Acrobat windows, before reprinting these reports."
            Exit Sub
        End If
         
        x = x + 1
        Part2Document.Close
        
        'Close the open pdf files except for the Merged report
        'FollowHyperlink Replace(pdfsrc, "1", X - 1), , True, False
        'SendKeys "%{F4}", False
        DoEvents
        On Error Resume Next
        Call WinClose(Replace(Mid(pdfsrc, InStrRev(pdfsrc, "\") + 1), "1", x - 1) & " - Adobe Acrobat Pro")
        DoEvents
        
                
        Part2Document.Open (Replace(pdfsrc, "1", x))
        'Debug.Print (Replace(pdfsrc, "1", x))
    Loop
    

    stMergename = "C:\Desktop\PrintFiles\Program_Summary_Combined.pdf"
    If Part1Document.Save(PDSaveFull, stMergename) = False Then
        MsgBox "Cannot save the modified document"
    End If
        
    Part1Document.Close
    Part2Document.Close
     
    AcroApp.Exit
    Set AcroApp = Nothing
    Set Part1Document = Nothing
    Set Part2Document = Nothing
    
    'Open merged file for review and printing
    FollowHyperlink stMergename, , True, False
    MsgBox "Done"
    
End Sub

Option Compare Database

'http://www.andreavb.com/forum/viewtopic_5604.html
'Post:Asim-GDI GURU

Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Const SW_SHOWNORMAL = 1
Const WM_CLOSE = &H10

Public Sub WinClose(WindowToClose As String)
    'KPD-Team 1998
    'URL: http://www.allapi.net/
    'E-Mail: KPDTeam@Allapi.net
    Dim WinWnd As Long ', Ret As String,
    Dim RetVal As Long, lpClassName As String
    'Ask for a Window title
    'Ret = InputBox("Enter the exact window title:" + Chr$(13) + Chr$(10) + "Note: must be an exact match")
    ret = WindowToClose
    'Search the window
    WinWnd = FindWindow(vbNullString, ret)
    If WinWnd = 0 Then MsgBox "Couldn't find the window ...": Exit Sub
    'Show the window
    ShowWindow WinWnd, SW_SHOWNORMAL
    'Post a message to the window to close itself
    PostMessage WinWnd, WM_CLOSE, 0&, 0&
End Sub