themanof83
Registered User.
- Local time
- Today, 01:11
- Joined
- May 1, 2008
- Messages
- 73
Hi all,
I have created a function that I feel is worth sharing although it isn't quite doing what I expect. Here's what I have in my database:
I've tried saving the file directly after changing each bookmark but this doesn't make any difference (and is a very slow process!).
I know that alot of the code here could be cleaned up with sub functions but here is what I've got.
Thanks in advance!
I have created a function that I feel is worth sharing although it isn't quite doing what I expect. Here's what I have in my database:
- I have a long list of Tests each with an assoicated PDF file
- Each of these tests has a specific ident but can belong to a specific section i.e. 1a, 1b, 1c.... 5e etc.
- Group all the tests by section and merge them all into a PDF with the title of that seciton i.e. 1a - TAXI.pdf
- Once the test PDF's are inserted rename the bookmarks to remove ".pdf" from any of the bookmarks
- Save and Close the respective test section PDF's
- Group all of the test section PDF's and merge them into one big pdf i.e. Validation Tests.pdf
- Again, once the section PDF's are inserted rename the bookmarks to remove ".pdf" from any of the bookmarks
I've tried saving the file directly after changing each bookmark but this doesn't make any difference (and is a very slow process!).
I know that alot of the code here could be cleaned up with sub functions but here is what I've got.
Code:
Private Sub Merge_Click()
Dim objCAcroPDDocDestination As Acrobat.AcroPDDoc
Dim objCAcroPDDocSource As Acrobat.AcroPDDoc
Dim objCAcroPDBookmark As CAcroPDBookmark
Dim fso As Scripting.FileSystemObject
Dim strSection As String, strFolder As String, strCreateFolder As String, strFolderSpec As String, strMsg As String
Dim strSectionLast As String, strMyFile As String, strPDFSave(50) As String, strPDFSaveFile(50) As String, strPDFFile(1000)
Dim PDFHyper As String, PDFIdent As String, TESTFileSpec As String, strLeft As String, strLeftLast As String
Dim strBMTitle As String, strMsgFail As String
Dim f As File
Dim fldr As Folder
Dim c As Control, d As Control
Dim chkFolder As Boolean, chkInsert As Boolean, chkRenameBM As Boolean, chkBMTitle As Boolean
Dim introw As Integer, k As Integer, l As Integer, m As Integer, n As Integer, intTotal As Integer
Set objCAcroPDDocDestination = CreateObject("AcroExch.PDDoc")
Set objCAcroPDDocSource = CreateObject("AcroExch.PDDoc")
Set objCAcroPDBookmark = CreateObject("AcroExch.PDBookmark")
Set fso = New Scripting.FileSystemObject
Set c = Me.ViewQTGTEST
Set c = Me.ViewQTGTEST
Set d = [Forms]![Select Programme]![SelectProg]
k = 0
l = 0
m = 0
intTotal = 0
'Check batch folder exists. If not create
strFolder = d.Column(2) & "\PDF"
chkFolder = fso.FolderExists(strFolder)
'Debug.Print strFolder, chkFolder
If c.Enabled = False Then
MsgBox "Please select a format (PDF or TEST) to View Tests.", vbInformation + vbOKOnly, _
"Select Format"
Exit Sub
End If
If (c.ItemsSelected.COUNT = 0) Then
Msg = "No tests selected. Do you want to merge complete suite of test PDF's?"
Response = MsgBox(Msg, vbInformation + vbOKCancel, "Merge Complete Set of Tests?")
If Response = vbOK Then
DoCmd.Hourglass True
'Select all tests
Call SelAll_Click
'Create appropriate folder
If chkFolder = False Then
fso.CreateFolder (strFolder)
'Debug.Print strCreateFolder
End If
'Get test PDF information
If (Nz(c.Column(2, introw), "") = "") Then
MsgBox "There is no associated folder supplied with the test: " & c.Column(0, introw), vbInformation + vbOKOnly, _
"No folder supplied"
Else
For introw = 0 To c.ListCount - 1
If c.Selected(introw) Then
strFolderSpec = GetFolderSpec(introw) & c.Column(2, introw) & "\"
TESTFileSpec = strFolderSpec & c.Column(0, introw) & ".test"
PDFIdent = GetPDFIdentFromFile(TESTFileSpec)
If Nz(PDFIdent, "") = "" Then
PDFIdent = c.Column(0, introw)
End If
'Calculate Section based on Ident
strLeft = Left(PDFIdent, 2)
If strLeft = "" Then
strSection = "N/A"
ElseIf strLeft = "1a" Then
strSection = "1a - TAXI"
ElseIf strLeft = "1b" Then
strSection = "1b - TAKE-OFF"
ElseIf strLeft = "1c" Then
strSection = "1c - CLIMB"
ElseIf strLeft = "1d" Then
strSection = "1d - CRUISE_DESCENT"
ElseIf strLeft = "1e" Then
strSection = "1e - STOPPING"
ElseIf strLeft = "1f" Then
strSection = "1f - ENGINES"
ElseIf strLeft = "2a" Then
strSection = "2a - STATIC CONTROLS"
ElseIf strLeft = "2b" Then
strSection = "2b - DYNAMIC CONTROLS"
ElseIf strLeft = "2c" Then
strSection = "2c - LONGITUDINAL"
ElseIf strLeft = "2d" Then
strSection = "2d - LATERAL"
ElseIf strLeft = "2e" Then
strSection = "2e - LANDING"
ElseIf strLeft = "2f" Then
strSection = "2f - GROUND EFFECT"
ElseIf strLeft = "2g" Then
strSection = "2g - WINDSHEAR"
ElseIf strLeft = "2h" Then
strSection = "2h - PROTECTION"
ElseIf strLeft = "3a" Then
strSection = "3a - FREQUENCY RESPONSE"
ElseIf strLeft = "3b" Then
strSection = "3b - LEG BALANCE"
ElseIf strLeft = "3c" Then
strSection = "3c - TURN AROUND CHECK"
ElseIf strLeft = "3d" Then
strSection = "3d - MOTION EFFECTS"
ElseIf strLeft = "3e" Then
strSection = "3e - MOTION REPEATABILITY"
ElseIf strLeft = "3f" Then
strSection = "3f - MOTION CUEING"
ElseIf strLeft = "3g" Then
strSection = "3g - MOTION VIBRATIONS"
ElseIf strLeft = "4a" Then
strSection = "4a - VISUAL RESPONSE"
ElseIf strLeft = "4b" Then
strSection = "4b - VISUAL SCENE QUALITY"
ElseIf strLeft = "4c" Then
strSection = "4c - VISUAL GROUND SEGMENT"
ElseIf strLeft = "4d" Then
strSection = "4d - VISUAL SYSTEM"
ElseIf strLeft = "4e" Then
strSection = "4e - VISUAL SYSTEM"
ElseIf strLeft = "4f" Then
strSection = "4f - VISUAL SYSTEM"
ElseIf strLeft = "4g" Then
strSection = "4g - VISUAL SYSTEM"
ElseIf strLeft = "5a" Then
strSection = "5a - TURBO-JET AEROPLANES"
ElseIf strLeft = "5b" Then
strSection = "5b - PROPELLER AEROPLANES"
ElseIf strLeft = "5c" Then
strSection = "5c - SPECIAL CASES"
ElseIf strLeft = "5d" Then
strSection = "5d - BACKGROUND NOISE"
ElseIf strLeft = "5e" Then
strSection = "5e - FREQUENCY RESPONSE"
Else
strSection = "N/A"
End If
If strLeftLast = "" Then
'Initialise array counter
k = 1
'Capture number of files created
m = k
'Initialise/Open Destination file
objCAcroPDDocDestination.Open strFolder & "\Template.pdf"
ElseIf Not (strLeft = strLeftLast) Then 'Check if section has changed
'Capture individual file counter
n = l
'Debug.Print strLeft, strLeftLast
'Save file name to array
strPDFSave(k) = strFolder & "\" & strSectionLast & ".pdf"
'Delete First Blank page
objCAcroPDDocDestination.DeletePages 0, 0
'Loop through all bookmarks referencing the TEST names
'of the merged files and remove ".pdf" from bookmark
For l = 1 To n
chkBMTitle = objCAcroPDBookmark.GetByTitle(objCAcroPDDocDestination, strPDFFile(l))
'Debug.Print strBMTitle, chkBMTitle
'Search for ".pdf" and Replace if found
If chkBMTitle = True Then
'If FindIt(strBMTitle, ".pdf") Then
chkRenameBM = objCAcroPDBookmark.SetTitle(Replace(strPDFFile(l), ".pdf", ""))
If chkRenameBM = True Then
'Debug.Print "SUCCESS!"
Else
'Debug.Print "FAILED!"
End If
End If
Next l
'Save/Close Destination file
objCAcroPDDocDestination.Save 1, strPDFSave(k)
objCAcroPDDocDestination.Close
'Update/Open Destination file, to which to add PDF's
objCAcroPDDocDestination.Open strFolder & "\Template.pdf"
'Increment counter
k = k + 1
'Capture number of files created
m = k
'Reset individual file counter
l = 0
ElseIf introw = c.ListCount - 1 Then
'Save file name to array
strPDFSave(k) = strFolder & "\" & strSectionLast & ".pdf"
'Delete First Blank page and Save/Close Destination file
objCAcroPDDocDestination.DeletePages 0, 0
'Loop through all bookmarks referencing the TEST names
'of the merged files and remove ".pdf" from bookmark
For l = 1 To n
chkBMTitle = objCAcroPDBookmark.GetByTitle(objCAcroPDDocDestination, strPDFFile(l))
'Debug.Print strBMTitle, chkBMTitle
'Search for ".pdf" and Replace if found
If chkBMTitle = True Then
'If FindIt(strBMTitle, ".pdf") Then
chkRenameBM = objCAcroPDBookmark.SetTitle(Replace(strPDFFile(l), ".pdf", ""))
If chkRenameBM = True Then
'Debug.Print "SUCCESS!"
Else
'Debug.Print "FAILED!"
End If
End If
Next l
'Save/Close Destination file
objCAcroPDDocDestination.Save 1, strPDFSave(k)
objCAcroPDDocDestination.Close
'Capture number of files created
m = k
End If
Set fldr = fso.GetFolder(strFolderSpec)
For Each f In fldr.Files
If (Right(f.Name, 3) = "pdf") Then
'Open the source document that will be added to the destination
objCAcroPDDocSource.Open (f)
chkInsert = objCAcroPDDocDestination.InsertPages(objCAcroPDDocDestination.GetNumPages - 1, objCAcroPDDocSource, 0, objCAcroPDDocSource.GetNumPages, True)
If chkInsert = True Then
'Increment number of files captured and file name
intTotal = intTotal + 1
l = l + 1
strPDFFile(l) = f.Name
'Debug.Print "SUCCESS!"
Else
strMsgFail = strMsgFail & vbCrLf & f.Name
'Debug.Print "FAILED!"
End If
Debug.Print l, strPDFFile(l), f, f.Name, strFolderSpec
'Close source document (no longer needed)
objCAcroPDDocSource.Close
Exit For
End If
Next f
'Debug.Print fldr, strLeft, strLeftLast, strSection, strSectionLast
'Capture Previous data
strLeftLast = strLeft
strSectionLast = strSection
End If
Next introw
''''''' Combine all Section PDF's '''''''
'Initialise/Open Destination file
objCAcroPDDocDestination.Open strFolder & "\Template.pdf"
Set fldr = fso.GetFolder(strFolder)
For Each f In fldr.Files
For k = 1 To m
strPDFSaveFile(k) = Replace(strPDFSave(k), strFolder & "\", "")
'Debug.Print f.Name, strPDFSaveFile(k)
If (f.Name = strPDFSaveFile(k)) Then
'Open the source document to add to destination
objCAcroPDDocSource.Open (f)
chkInsert = objCAcroPDDocDestination.InsertPages(objCAcroPDDocDestination.GetNumPages - 1, objCAcroPDDocSource, 0, objCAcroPDDocSource.GetNumPages, 1)
If chkInsert = True Then
'Debug.Print "SUCCESS!"
strMsg = strMsg & vbCrLf & strPDFSaveFile(k)
Else
'Debug.Print "FAILED!"
strMsgFail = strMsgFail & vbCrLf & strPDFSaveFile(k)
End If
'Remove ".pdf" from bookmarks
chkBMTitle = objCAcroPDBookmark.GetByTitle(objCAcroPDDocDestination, strPDFSaveFile(k))
'Debug.Print strBMTitle, chkBMTitle
'Search for ".pdf" and Replace if found
If chkBMTitle = True Then
'If FindIt(strBMTitle, ".pdf") Then
chkRenameBM = objCAcroPDBookmark.SetTitle(Replace(strPDFSaveFile(k), ".pdf", ""))
If chkRenameBM = True Then
'Debug.Print "SUCCESS!"
Else
'Debug.Print "FAILED!"
End If
End If
'Close source document (no longer needed)
objCAcroPDDocSource.Close
Exit For
End If
Next k
Next f
'Delete First Blank page and Save/Close Destination file
objCAcroPDDocDestination.DeletePages 0, 0
objCAcroPDDocDestination.Save 1, strFolder & "\Validation Tests.pdf"
objCAcroPDDocDestination.Close
'Check all files have been merged succesfully
If intTotal = c.ListCount - 1 Then
Msg = "The following files have succesfully been created and merged in to the following PDF:" & vbCrLf & vbCrLf & _
strFolder & "\Validation Tests.pdf" & vbCrLf & strMsg & vbCrLf & vbCrLf & _
"Would you like to view the created file?"
Response = MsgBox(Msg, vbInformation + vbYesNo, "Files Created Succesfully!")
If Response = vbYes Then
OpenPDFDocument (strFolder & "\Validation Tests.pdf")
End If
Else
Msg = "The following files have NOT been succesfully merged in to the respective PDF(s):" & vbCrLf & _
strMsgFail & vbCrLf & vbCrLf & "Please apply corrective action!" & vbCrLf & vbCrLf & _
"However, all other files have succesfully been created and merged into the following PDF:" & vbCrLf & vbCrLf & _
strFolder & "\Validation Tests.pdf" & vbCrLf & strMsg & vbCrLf & vbCrLf & _
"Would you like to view the created file?"
Response = MsgBox(Msg, vbExclamation + vbYesNo, "Files Created with Errors!")
If Response = vbYes Then
OpenPDFDocument (strFolder & "\Validation Tests.pdf")
End If
End If
Call ClearList_Click
End If
Else
End
End If
ElseIf (c.ItemsSelected.COUNT > 1) Then
DoCmd.Hourglass True
'Create appropriate folder
If chkFolder = False Then
fso.CreateFolder (strFolder)
'Debug.Print strCreateFolder
End If
'Get test PDF information
If (Nz(c.Column(2, introw), "") = "") Then
MsgBox "There is no associated folder supplied with the test: " & c.Column(0, introw), vbInformation + vbOKOnly, _
"No folder supplied"
Else
strMyFile = InputBox("Please Enter File Name to Save Merged PDF.", "PDF File Name")
'Check validity of input
If (Nz(strMyFile, "") = "") Then
MsgBox "Please enter a file name!", vbExclamation + vbOKOnly, "Invalid File Name!"
DoCmd.Hourglass False
Call ClearList_Click
Exit Sub
ElseIf (Right(strMyFile, 4) = ".pdf") Then
strMyFile = Replace(strMyFile, ".pdf", "")
End If
Debug.Print strMyFile
For introw = 0 To c.ListCount - 1
If c.Selected(introw) Then
strFolderSpec = GetFolderSpec(introw) & c.Column(2, introw) & "\"
TESTFileSpec = strFolderSpec & c.Column(0, introw) & ".test"
PDFIdent = GetPDFIdentFromFile(TESTFileSpec)
If Nz(PDFIdent, "") = "" Then
PDFIdent = c.Column(0, introw)
End If
'Initialise/Open Destination file
objCAcroPDDocDestination.Open strFolder & "\Template.pdf"
Set fldr = fso.GetFolder(strFolderSpec)
For Each f In fldr.Files
If (Right(f.Name, 3) = "pdf") Then
'Increment counter
l = l + 1
'Open the source document that will be added to the destination
objCAcroPDDocSource.Open (f)
chkInsert = objCAcroPDDocDestination.InsertPages(objCAcroPDDocDestination.GetNumPages - 1, objCAcroPDDocSource, 0, objCAcroPDDocSource.GetNumPages, True)
strPDFFile(l) = f.Name
If chkInsert = True Then
intTotal = intTotal + 1
'Debug.Print "SUCCESS!"
strMsg = strMsg & vbCrLf & strPDFFile(l)
Else
'Debug.Print "FAILED!"
strMsgFail = strMsgFail & vbCrLf & strPDFFile(l)
End If
'Close source document (no longer needed)
objCAcroPDDocSource.Close
Exit For
End If
Next f
End If
If introw = c.ListCount - 1 Then
'Delete First Blank page and Save/Close Destination file
objCAcroPDDocDestination.DeletePages 0, 0
objCAcroPDDocDestination.Save 1, strFolder & "\" & strMyFile & ".pdf"
objCAcroPDDocDestination.Close
Exit For
End If
Next introw
'Check all files have been merged succesfully
If intTotal = l Then
Msg = "The following files have succesfully been created and merged in to the following PDF:" & vbCrLf & vbCrLf & _
strFolder & "\" & strMyFile & ".pdf" & vbCrLf & strMsg & vbCrLf & vbCrLf & _
"Would you like to view the created file?"
Response = MsgBox(Msg, vbInformation + vbYesNo, "Files Created Succesfully!")
If Response = vbYes Then
OpenPDFDocument (strFolder & "\" & strMyFile & ".pdf")
End If
Else
Msg = "The following files have NOT been succesfully merged in to the respective PDF(s):" & vbCrLf & _
strMsgFail & vbCrLf & vbCrLf & "Please apply corrective action!" & vbCrLf & vbCrLf & _
"However, all other files have succesfully been merged into the following PDF:" & vbCrLf & vbCrLf & _
strFolder & "\" & strMyFile & ".pdf" & vbCrLf & strMsg & vbCrLf & vbCrLf & _
"Would you like to view the created file?"
Response = MsgBox(Msg, vbExclamation + vbYesNo, "Files Created with Errors!")
If Response = vbYes Then
OpenPDFDocument (strFolder & "\" & strMyFile & ".pdf")
End If
End If
End If
Call ClearList_Click
ElseIf (c.ItemsSelected.COUNT = 1) Then
MsgBox "A single test cannot be merged!" & vbCrLf & "Please select more than one test.", _
vbExclamation + vbOKOnly, "Insufficient Test Selection!"
Call ClearList_Click
Exit Sub
End If
Set f = Nothing
Set fldr = Nothing
Set fso = Nothing
Set objCAcroPDDocSource = Nothing
Set objCAcroPDDocDestination = Nothing
DoCmd.Hourglass False
End Sub
