Sub sndbxExportPDF() 'pdfExportLoc)
'=== John_w's suggestion: create separate PDFs for each sheet with exportasfixedformat, loop through saved PDFs and use acrobat api to merge and add bookmarks
'temporary pdfExportLoc (will be replaced by a pushed variable in the sub declaration)
Dim pdfExportLoc As String
pdfExportLoc = ActiveWorkbook.Path
'end temp
pdfExportLoc = pdfExportLoc & "\" & Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 5) & ".pdf"
' save each sheet as separate PDF | source: https://exceloffthegrid.com/vba-code-save-excel-file-as-pdf/#Loop_through_sheets
Dim ws As Worksheet
Dim tempFolder As String
tempFolder = ActiveWorkbook.Path & "\Temp"
If Dir(tempFolder, vbDirectory) = vbNullString Then 'Create temporary folder
MkDir tempFolder
End If
For Each ws In ActiveWorkbook.Worksheets 'Loop through all worksheets and save as individual PDF in Temp folder
ws.ExportAsFixedFormat Type:=xlTypePDF, _
fileName:=tempFolder & "\" & ws.Name & ".pdf"
Next
'**** The above is tested and works. What follows has not been tested.
' I've not used John_w's merge link 1 because it takes everything from cells in a sheet; I found the following code to merge files in a directory | source: http://www.vbaexpress.com/forum/showthread.php?47310-Need-code-to-merge-PDF-files-in-a-folder-using-adobe-acrobat-X&p=295941&viewfull=1#post295941
Const DestFile As String = pdfExportLoc & "\" & Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 5) & ".pdf" ' << I don't know if this will work because this file doesn't exist (yet)
Dim MyPath As String, MyFiles As String
Dim i As Long ' << removed variables a() and f because of changed code
' I replaced the With block defining MyPath with a simple declaration setting MyPath to the tempFolder
MyPath = tempFolder & "\"
' I replaced the code here (array a() ) with something I wrote yesterday and have modified, which hopefully will work to preserve the order of the sheets
Dim ws As Worksheet
Dim shtArray() As String
Dim intA As Integer
For Each ws In ActiveWorkbook.Worksheets
intA = intA + 1
ReDim Preserve shtArray(intA)
shtArray(intA) = tempFolder & "\" & ws.Name & ".pdf"
Next ws
If i Then ' Merge PDFs
ReDim Preserve shtArray(1 To i)
MyFiles = Join(shtArray, ",")
Application.StatusBar = "Merging, please wait ..."
Call MergePDFs(MyPath, MyFiles, shtArray, DestFile) ' << go to the next sub
Application.StatusBar = False
Else
MsgBox "No PDF files found in" & vbLf & MyPath, vbExclamation, "Canceled"
End If
' merge pdf and set bookmarks (from John_w's answer) | source: https://www.mrexcel.com/board/threads/create-pdf-bookmarks-while-combinding-files-with-vba-in-excel.847138/#post-4124136 _
Maybe this part belongs in the next sub when it merges the files?
Dim insertSuccess As Boolean
Dim n As Long, p As Long
Dim JSO As Object, BookmarkRoot As Object
p = objAcroPDDocDestination.GetNumPages
insertSuccess = objAcroPDDocDestination.InsertPages(p - 1, objAcroPDDocSource, 0, objAcroPDDocSource.GetNumPages, 0)
If insertSuccess Then
Set JSO = objAcroPDDocDestination.GetJSObject
Set BookmarkRoot = JSO.BookmarkRoot
n = UBound(BookmarkRoot.Children) + 1
BookmarkRoot.createChild shtArray(n), "this.pageNum=" & p, n ' << I don't know if I updated this correctly
End If
objAcroPDDocDestination.Save 1, FromPath & ParentFolder & ParentFile
objAcroPDDocSource.Close
' Delete the temporary folder | source: https://www.automateexcel.com/vba/deletefolder/
Dim FSO As New FileSystemObject
Set FSO = CreateObject("Scripting.FileSystemObject")
FSO.DeleteFolder tempFolder, False
End Sub
Sub MergePDFs(MyPath As String, MyFiles As String, shtArray As String, Optional DestFile As String)
' This entire sub is Greek to me. I don't understand any of it, and I have no idea what needs to be changed. Maybe it's fine as it, but I doubt it.
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.AcroPDDoc
If Right(MyPath, 1) = "\" Then p = MyPath Else p = MyPath & "\" ' << this whole block is also in the previous sub...seems redundant...
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
n = n + ni ' Calc the number of pages in the merged document
PartDocs(i).Close ' Release the memory
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_:
If Err Then ' Inform about error/success
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
If Not PartDocs(0) Is Nothing Then PartDocs(0).Close ' Release the memory
Set PartDocs(0) = Nothing
AcroApp.Exit ' Quit Acrobat application
Set AcroApp = Nothing
End Sub
