Looping for set

[rclark]

Well, I'm bad at this, so, please help! I have code that pulls pdf files and saves them as a binder. It all works, but as I expand the code, I start creating a lot of repetitious things that can probably be lopped, but I'm just not bright enough to get my head around it. Below is the code that will create the first doc from a tab as a cover sheet, and pull 2 more existing files into the binder. I would like to do this with up to 100 without haveing to copy and paste the code so many times.


Sub Build_Packet()


Dim AcroApp As Acrobat.CAcroApp
Dim Part1Document As Acrobat.CAcroPDDoc
Dim numPages As Integer
Set AcroApp = CreateObject("AcroExch.App")


Set Part1Document = CreateObject("AcroExch.PDDoc")
Set Part2Document = CreateObject("AcroExch.PDDoc")
Set Part3Document = CreateObject("AcroExch.PDDoc")



' Open Part1Document and save as Binder Name
Sheets("Planning").Range("A1:B40").ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
(Worksheets("RefData").Range("PACKETPREFIX") & "\tempcover.pdf"), Quality:= _
xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=False


' Open Part1Document as cover sheet to append additional pdfs
Part1Document.Open (Worksheets("RefData").Range("PACKETPREFIX") & "\tempcover.pdf")
' Open PartcDocuments to be appended into Part1Document
If Worksheets("Planning").Range("FILE1") = "" Then
Else
Part2Document.Open (Worksheets("RefData").Range("FILEPREFIX") & "" & Worksheets("Planning").Range("FILE1"))
End If
If Worksheets("Planning").Range("FILE2") = "" Then
Else
Part3Document.Open (Worksheets("RefData").Range("FILEPREFIX") & "" & Worksheets("Planning").Range("FILE2"))
End If

' Append PartxDocument files into Part1Document


numPages = Part1Document.GetNumPages()

' AppendPart2Document
If Worksheets("Planning").Range("FILE1") = "" Then
Else
If Part1Document.InsertPages(numPages - 1, Part2Document, 0, Part2Document.GetNumPages(), True) = False Then
MsgBox "Cannot insert page 1"
End If
End If
If Part1Document.Save(PDSaveFull, Worksheets("RefData").Range("PACKETPREFIX") & "" & Worksheets("RefData").Range("PACKETNAME") & ".pdf") = False Then
MsgBox "Cannot save the modified document"
End If

' AppendPart3Document
If Worksheets("Planning").Range("FILE2") = "" Then
Else
If Part1Document.InsertPages(numPages - 1, Part3Document, 0, Part3Document.GetNumPages(), True) = False Then
MsgBox "Cannot insert page 1"
End If
End If
If Part1Document.Save(PDSaveFull, Worksheets("RefData").Range("PACKETPREFIX") & "" & Worksheets("RefData").Range("PACKETNAME") & ".pdf") = False Then
MsgBox "Cannot save the modified document"
End If

' ClosebPartxDocuments
Part1Document.Close
Part2Document.Close
Part3Document.Close

' Not sure what this does
AcroApp.Exit
Set AcroApp = Nothing
Set Part1Document = Nothing
Set Part2Document = Nothing
Set Part3Document = Nothing



MsgBox "Packet Complete. Go To: " & Worksheets("RefData").Range("PACKETPREFIX") & " To Access File: " & Worksheets("RefData").Range("PACKETNAME")


' Delete the Part1Document file cover sheet
Dim KillFile As String
KillFile = Worksheets("RefData").Range("PACKETPREFIX") & "\tempcover.pdf"
'Check that file exists
If Len(Dir$(KillFile)) > 0 Then
'First remove readonly attribute, if set
SetAttr KillFile, vbNormal
'Then delete the file
Kill KillFile
End If

End Sub

 

[baitmaster]

Hi I'm unable to test this in any way, but I suspect it needs to look something like the following:

Option Explicit

Sub Build_Packet()

Dim docShell As Acrobat.CAcroPDDoc, docNextPart As Acrobat.CAcroPDDoc
Dim numPages As Integer, numPagesTotal As Integer
 
Dim AcroApp As Acrobat.CAcroApp: Set AcroApp = CreateObject("AcroExch.App")
Set docShell = CreateObject("AcroExch.PDDoc")

' Open Part1Document and save as Binder Name
Sheets("Planning").Range("A1:B40").ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
(Worksheets("RefData").Range("PACKETPREFIX") & "\tempcover.pdf"), Quality:= _
xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=False

' Open document shell as cover sheet to append additional pdfs
docShell.Open (Worksheets("RefData").Range("PACKETPREFIX") & "\tempcover.pdf")
numPages = docShell.GetNumPages()

' Open PartcDocuments to be appended into Part1Document
' Range("File1") should be replaced with a table of cells that can be easily looped through
Dim cl As Range, strThis As String
For Each cl In Range("myListOfFiles")
    
    strThis = cl.Value
    
    If strThis = "" Then
        GoTo loopEnd
    Else
        Set docNextPart = CreateObject("AcroExch.PDDoc")
        docNextPart.Open (Worksheets("RefData").Range("FILEPREFIX") & "" & strThis)
    
        numPages = numPages + docNextPart.GetNumPages()
        
        If docShell.InsertPages(numPages - 1, docNextPart, 0, docNextPart.GetNumPages(), True) = False Then
            MsgBox "Cannot insert page 1" & vbCr & strThis, vbExclamation
        End If
    
        If docShell.Save(PDSaveFull, Worksheets("RefData").Range("PACKETPREFIX") & "" & Worksheets("RefData").Range("PACKETNAME") & ".pdf") = False Then
           MsgBox "Cannot save the modified document"
        End If
    
    End If
Next cl

loopEnd:
' Append PartxDocument files into Part1Document
numPages = docShell.GetNumPages()
' Close source documents and release from memory
docShell.Close: Set docShell = Nothing
docNextPart.Close: Set docNextPart = Nothing
AcroApp.Exit: Set AcroApp = Nothing
MsgBox "Packet Complete. Go To: " & Worksheets("RefData").Range("PACKETPREFIX") & " To Access File: " & Worksheets("RefData").Range("PACKETNAME")
' Delete the Part1Document file cover sheet
Dim KillFile As String
KillFile = Worksheets("RefData").Range("PACKETPREFIX") & "\tempcover.pdf"
'Check that file exists
If Len(Dir$(KillFile)) > 0 Then
'First remove readonly attribute, if set
SetAttr KillFile, vbNormal
'Then delete the file
Kill KillFile
End If
End Sub

You'll need to get rid of File1, File2 named ranges and replace with a single continuous table of values, when a blank is found the loop ends

 

[rclark]

baitmaster, you replied yesterday with another solution but I didn't get to it before it was lost. Could you please repost?

 

[baitmaster]

Sadly I didn't save it, I don't usually save the stuff I post on here - if I need to refer back to it I just grab the code back off the site. But then the site was attacked which is fairly unprecedented - I guess the Russians are trying to steal our publicly-available Excel/VBA secrets or something...!

OK I've had another go. I'm doing several things which aim to simplify and clarify, which makes errors easier to spot.
- First I've pulled together all the file name declarations into one block with meaningful names - you should review these and check they make sense. You also need to ensure they have the correct file name delimiters ("/") in the right places, as I suspect that some of yours don't have the "/" (or " \ "?) between the last folder and the file name
- Second I've added some debug.print lines, these will report key information to the Immediate Window (Gtrl + G to view) which you can review after the code run. Use these to check everything runs in the order you expect, and that the text strings, page counts etc. are what you expect to see

I've also closed the docNextPart object and set it to nothing during the loops, as I suspect this could be a source of a problem - it was already created by loop 1, then loop 2 tried to recreate it. On that note, you might want to try and get the code working a bit at a time - run it for just the shell object, then add 1 file, then add multiple files

Option Explicit
Sub Build_Packet()
Dim AcroApp As Acrobat.CAcroApp: Set AcroApp = CreateObject("AcroExch.App")
Dim docShell As Acrobat.CAcroPDDoc: Set docShell = CreateObject("AcroExch.PDDoc")
Dim docNextPart As Acrobat.CAcroPDDoc
Dim numPages As Integer, numPagesTotal As Integer

' declare all file name strings. ## check these objects make sense ##
Dim strPacketPrefix As String: strPacketPrefix = Worksheets("RefData").Range("PACKETPREFIX")
Dim strFilePrefix As String: strFilePrefix = Worksheets("RefData").Range("FILEPREFIX")
Dim strTempFileFullName As String: strTempFileFullName = strPacketPrefix & "\tempcover.pdf"
Dim strPacketName As String: strPacketName = Worksheets("RefData").Range("PACKETNAME") & ".pdf"
Dim strPacketFullName As String: strPacketFullName = strPacketPrefix & strPacketName ' does this need [& "\" &] added between prefix and filename?

' report text strings for error checking later
Debug.Print strPacketPrefix
Debug.Print strFilePrefix
Debug.Print strTempFileFullName
Debug.Print strPacketName
Debug.Print strPacketFullName

' Open Part1Document and save as Binder Name
Sheets("Planning").Range("A1:B40").ExportAsFixedFormat Type:=xlTypePDF, Filename:=strTempFileFullName, Quality:= _
    xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False

' Open document shell as cover sheet to append additional pdfs
docShell.Open (strTempFileFullName)
numPagesTotal = docShell.GetNumPages()

' Open PartcDocuments to be appended into Part1Document
' Range("File1") should be replaced with a table of cells that can be easily looped through
Dim cl As Range, strThis As String
For Each cl In Range("myListOfFiles")
    
    strThis = cl.Value
    
    If strThis = "" Then
        Debug.Print "ending at blank cell: " & cl.Address
        GoTo loopEnd
        
    Else
        Set docNextPart = CreateObject("AcroExch.PDDoc")
        
        Debug.Print "opening file: " & strFilePrefix & strThis
        
        docNextPart.Open (strFilePrefix & strThis) ' does this need [& "\" &] added between prefix and filename?
        
        numPages = docNextPart.GetNumPages()
        numPagesTotal = numPagesTotal + numPages
        
        Debug.Print numPages & " pages found", numPagesTotal & " total pages" ' report progress
        
        If docShell.InsertPages(numPagesTotal - 1, docNextPart, 0, numPages, True) = False Then
            Debug.Print "insert error"
            MsgBox "Cannot insert page 1" & vbCr & strThis, vbExclamation
        End If
        
        If docShell.Save(PDSaveFull, strPacketName) = False Then
            Debug.Print "save error"
            MsgBox "Cannot save the modified document"
        End If
        
        docNextPart.Close: Set docNextPart = Nothing ' Close source documents and release from memory
        
    End If
Next cl

loopEnd:
' Close source documents and release from memory
docShell.Close: Set docShell = Nothing
AcroApp.Exit: Set AcroApp = Nothing
MsgBox "Packet Complete. Go To: " & strPacketPrefix & " To Access File: " & strPacketName
' Delete the Part1Document file cover sheet
Dim KillFile As String
KillFile = strTempFileFullName
'Check that file exists
If Len(Dir$(KillFile)) > 0 Then
'First remove readonly attribute, if set
SetAttr KillFile, vbNormal
'Then delete the file
Kill KillFile
End If
End Sub

 

[baitmaster]

another error check you could do (during development only) is to incrementally save the temp file and then not kill it. You can then go in and review each file that was created and see if that tells you something. I suspect this would maybe be ok for the shell object, but then fall over for the first or second file append - but that's just a theory based on having not cleared the docNextPart object during the loops. We'll probably also be able to see this issue from the page counts, which should tell us whether each file successfully opened

 

[rclark]

Thank you again for you help with this. I skipped the kill file stuff and it looks like it is only creating the tempfile pdf. when I run the macro I get a 'cannot insert' error as well as a 'error saving' error. Below is what turned up in the Immediate window when I Ctrl+G after the code. I'm still looking at the code to make sure it makes sense, which, to the best of my knowledge, it does, but I'm going to keep looking.


C:\Users\rclark.MIDLOTHIANBIBLE\Desktop\PDF Test Folder\
C:\Users\rclark.MIDLOTHIANBIBLE\Desktop\PDF Test Folder\
C:\Users\rclark.MIDLOTHIANBIBLE\Desktop\PDF Test Folder\tempcover.pdf
1Batch-120316.pdf
C:\Users\rclark.MIDLOTHIANBIBLE\Desktop\PDF Test Folder\1Batch-120316.pdf
opening file: C:\Users\rclark.MIDLOTHIANBIBLE\Desktop\PDF Test Folder\NoAccessToStage.pdf
1 pages found 2 total pages
insert error
save error
opening file: C:\Users\rclark.MIDLOTHIANBIBLE\Desktop\PDF Test Folder\PleaseStayOffStage.pdf
1 pages found 3 total pages
insert error
save error
opening file: C:\Users\rclark.MIDLOTHIANBIBLE\Desktop\PDF Test Folder\WorshipMembers2016.pdf
1 pages found 4 total pages
insert error
save error
ending at blank cell: $B$8

 

[baitmaster]

For this code to work it needs some form of reference to Acrobat - can you tell me which reference it needs? I can't test or investigate further without it. For me to test I'd ideally need a copy of your PDFs as well, I can create my own but may have e.g. security settings incorrect

Looking at the debug.print results, do they all look correct?
are all addresses exactly as expected?
do all documents have only one page?

I suspect there's something wrong with the page counts or how they're being used, you might consider another debug.print numPages higher up, after creating the shell object to check we're getting the right value from the cover document. You'll note that every page count says 1, and the following line tries to subtract 1, meaning we are trying to insert at page 0: I'm unfamiliar with this code so I can't say it's right or not:

If docShell.InsertPages(numPagesTotal - 1, docNextPart, 0, numPages, True) = False Then

At the very least, double check that I'm getting/using the right values

 

[rclark]

I have Adobe Acrobat 10.0 Type Library selected in my references. I do know that the binding/inserting feature in not available with Adobe Reader. Pro is required. Yes, each sample PDF is one page, but it feels a bit like I'm referencing the list (myListofFiles) incorrectly, because the file names never show up in the immediate window. I made a new named range in the column that has my file names called myListofFiles. That contain the following filenames:

abcR39323-1330.pdf

abcR39323-1336.pdf

<colgroup><col></colgroup><tbody>
</tbody>

I also added the worksheet so it looked like the rest of my named ranges in the code:

For Each cl In Worksheets("Planning").Range("myListOfFiles")


As far as paths:
The cell for PACKETNAME contains 1Batch-112216
The cell for PACKETPREFIX contains C:\Users\myinfo\Desktop\
The cell for FILEPREFIX contains \\server\Folder1\Folder2\Folder3\

when I use my big code with no loops, things do pull appropriately, so it's either something over my head with the new code, or me doing something wrong with the associations to the correct data.

 

[baitmaster]

it feels a bit like I'm referencing the list (myListofFiles) incorrectly, because the file names never show up in the immediate window

but the immediate window contained:

opening file: C:\Users\rclark.MIDLOTHIANBIBLE\Desktop\PDF Test Folder\NoAccessToStage.pdf
 1 pages found 2 total pages

which suggests that (1) you've used the correct address, and (2) you've been able to open the file and count the pages in it

I want to test if docShell and docNextPart exist after they've been opened, and try and get some info about them. I can't do this without referencing the object library as I don't know what objects are available. .name usually exists so can we try adding the following debug lines where shown:

docShell.Open (strTempFileFullName)
[COLOR=#FF0000]debug.print docShell.name[/COLOR]

------------

docNextPart.Open (strFilePrefix & strThis)
[COLOR=#FF0000]debug.print docNextPart.name[/COLOR]

With properly declared objects we also have the "helper list" pop up as we type. So if this doesn't work, in the immediate window, type "docshell." and you should get a scroll list appear with the various properties and methods of that object, because you've referenced the library. Look through this list and see if anything looks like it will be of use (.name is the one I'm guessing is there)