Sub MergePDF()
'NEED TO MODIFY TO WORK FOR UG------
'Combined multiple PDF files into one
'set a reference to Acrobat (Adobe Acrobat 7.0 Type Library)
'[URL unfurl="true"]http://www.khk.net/wordpress/2009/03/04/adobe-acrobat-and-vba-an-introduction/[/URL]
'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 = "\\Server\PDFfiles\YourPDFfile.pdf"
x = 1
Part1Document.Open (pdfsrc)
Part2Document.Open (Replace(pdfsrc, "0", x))
Do While x < 9
' 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, "0", 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, "0", X - 1), , True, False
'SendKeys "%{F4}", False
DoEvents
On Error Resume Next
' Call WinClose(Replace(Mid(pdfsrc, InStrRev(pdfsrc, "\") + 1), "0", x - 1) & " - Adobe Acrobat Pro")
DoEvents
Part2Document.Open (Replace(pdfsrc, "0", x))
'Debug.Print (Replace(pdfsrc, "0", x))
Loop
If Me.chkFall = True Then stTerm = "F" Else stTerm = "S"
stMergename = Replace(pdfsrc, "YourPDFfile0", "YourMergeNamePrefix" & Right(Me.txtCurrentYr, 2) & stTerm & "_" & Format(Me.txtRunDate, "YYYYMMDD") & "Full")
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
'FileCopy Replace(pdfsrc, "0", "1"), Replace(stMergename, "Full", "")
FileCopy pdfsrc, Replace(stMergename, "Full", "")
'Call WinClose("rptCover.pdf - Adobe Acrobat Pro")
'Open merged file for review and printing
' FollowHyperlink stMergename, , True, False
MsgBox "Done"
End Sub
Private Function ApplyBackgroundToPDF(BasePDF As String, BackgroundPDF As String, OutputPDF As String)
'Programmatically Add Watermark to PDF Document
'thread222 -1252388
'[URL unfurl="true"]http://www.tek-tips.com/viewthread.cfm?qid=1252388[/URL]
'modified from [URL unfurl="true"]http://diaryproducts.net/for/programmer/adobe_acrobat_pdf_scripting_visualbasic_javascript[/URL]
Dim pdDoc As Acrobat.AcroPDDoc
Dim fso As New FileSystemObject
Dim template As Variant
'Check for existence of output file
If fso.FileExists(OutputPDF) Then fso.DeleteFile OutputPDF
'Open base document
Set pdDoc = CreateObject("AcroExch.PDDoc")
pdDoc.Open BasePDF
DoEvents
'Initialize JavaScript
Set template = pdDoc.GetJSObject
'Place the template as a watermark
template.addWatermarkFromFile BackgroundPDF
'Save
pdDoc.Save 1, OutputPDF
'Close & Destroy Objects
pdDoc.Close
Set pdDoc = Nothing
Set template = Nothing
Set fso = Nothing
End Function