Automatic Printing to a PDF - here's how to do it

[SteveF]

I've searched the message board and found several questions, but not a good example of how to print automatically from Excel to a PDF file. After a couple of days of searching and tweaking, I've got what I think is a fairly good solution for automating your printing of worksheets to PDF files.

This solution requires the use of PDF995. This is a free utility available at www.PDF995.com. This is a print driver that allows you to print to a PDF file. The file is compatible with Adobe and can be read with the Adobe reader like any other PDF. The free version does pop-up some advertising with each print, but the automation works with around the pop-ups. I believe the full license version is about $10 and doesn't produce the pop-ups.

The challenge in automating a PDF process is that the PDF driver will prompt the user for a filename. This is ok if you are printing just one sheet, but if you need to automate the production of several PDFs, you need to be able to specify the name of the file in the code. The subroutine SheetToPDF presented below allows you to specify a single worksheet and the full filename for the PDF. I've included all the code and external declarations needed. The two subs at the bottom give examples of how to call SheetToPDF with the passed parameters.

I hope you find this helpful.
Regards,
Steve

-----------------------------------------------------
'Needed to Read INI file settings
Declare Function GetPrivateProfileString Lib "kernel32" Alias _
"GetPrivateProfileStringA" (ByVal lpApplicationName As String, _
ByVal lpKeyName As Any, ByVal lpDefault As String, _
ByVal lpReturnedString As String, ByVal nSize As Long, _
ByVal lpFileName As String) As Long

'Needed to Write INI file settings
Declare Function WritePrivateProfileString Lib "kernel32" Alias _
"WritePrivateProfileStringA" (ByVal lpApplicationName As String, _
ByVal lpKeyName As Any, ByVal lpString As Any, _
ByVal lpFileName As String) As Long

Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)


Sub SheetToPDF(WS As Worksheet, OutputFile As String)

' This subroutine will print a worksheet to a PDF file using PDF995, a free utility
' to generate PDF files. Download it at www.pdf995.com

' Two arguments must be passed into this routine
' 1. WS - A worksheet pointer
' 2. OutputFile - The full path and name of the desired pdf file

' Be sure to check that the "Generating PDF CS" setting in pdfsync.ini is set to 0
' when pdf995 is idle. This codes uses that as a completion flag as it seems to be
' the most reliable indication that PDF995 is done writing the pdf file.

Dim syncfile As String, maxwaittime As Long
Dim iniFileName As String 'tmpPrinter As Printer
Dim x As Long
Dim tmpoutputfile As String, tmpAutoLaunch As String

' set the location of the PDF995.ini and the pdfsync files
iniFileName = "c:\pdf995\res\pdf995.ini"
syncfile = "c:\pdf995\res\pdfsync.ini"

' save current settings from the PDF995.ini file
tmpoutputfile = ReadINIfile("PARAMETERS", "Output File", iniFileName)
tmpAutoLaunch = ReadINIfile("PARAMETERS", "Autolaunch", iniFileName)

' remove previous pdf if it exists
On Error Resume Next
Kill OutputFile
On Error GoTo Cleanup

' setup new values in PDF995.ini
x = WritePrivateProfileString("PARAMETERS", "Output File", OutputFile, iniFileName)
x = WritePrivateProfileString("PARAMETERS", "AutoLaunch", "0", iniFileName)

'print the worksheet
WS.Select
ActiveWindow.SelectedSheets.PrintOut Copies:=1, ActivePrinter:="PDF995"

' PDF995 operates asynchronously. We need to determine when it is done so we can
' continue. This is done by checking the "Generating PDF CS" parameter in the pdfsync.ini
' file. A loop with a 2 second delay is used to determine when it is finished.

Sleep (2000) ' pause 2 seconds (1000 = 1 sec)
maxwaittime = 60000 'If pdf995 isn't done in 60 seconds, quit anyway
Do While ReadINIfile("PARAMETERS", "Generating PDF CS", syncfile) = "1" And maxwaittime > 0
Sleep (2000) ' pause 2 seconds and re-check the status
maxwaittime = maxwaittime - 2000
Loop

' restore the original default printer and the PDF995.ini settings
Cleanup:
x = WritePrivateProfileString("PARAMETERS", "Output File", tmpoutputfile, iniFileName)
x = WritePrivateProfileString("PARAMETERS", "AutoLaunch", tmpAutoLaunch, iniFileName)
x = WritePrivateProfileString("PARAMETERS", "Launch", "", iniFileName)
On Error Resume Next


End Sub

Function ReadINIfile(sSection As String, sEntry As String, sFilename As String) As String
Dim x As Long
Dim sDefault As String
Dim sRetBuf As String, iLenBuf As Integer
Dim sValue As String

'Six arguments
'Explanation of arguments:
'sSection: ini file section (always between brackets)
'sEntry : word on left side of "=" sign
'sDefault$: value returned if function is unsuccessful
'sRetBuf$ : the value you're looking for will be copied to this buffer string
'iLenBuf% : Length in characters of the buffer string
'sFileName: Path to the ini file

sDefault$ = ""
sRetBuf$ = String$(256, 0) '256 null characters
iLenBuf% = Len(sRetBuf$)
x = GetPrivateProfileString(sSection, sEntry, _
sDefault$, sRetBuf$, iLenBuf%, sFilename)
ReadINIfile = Left$(sRetBuf$, x)

End Function


Sub PrintToPDF()
' This example prints the first sheet of the workbook. It calls the SheetToPDF subroutine,
' passing it the worksheet pointer, and the PDFFileName (the worksheet name + .pdf)

Dim PDFFileName As String
PDFFileName = "c:\temp\" & Sheets(1).Name & ".pdf"
Call SheetToPDF(Sheets(1), PDFFileName)
End Sub


Sub PrintCPSheets()
' This example prints specific named worksheets. It calls the SheetToPDF subroutine one
' time for each sheet, passing it a worksheet pointer, and PDFFileName.

Dim CS As Worksheet
Dim PDFFileName As String

CurrentPath = "c:\temp\"

Set CS = Sheets("West")
PDFFileName = CurrentPath & CS.Name & ".pdf"
Call SheetToPDF(CS, PDFFileName)

Set CS = Sheets("Northeast")
PDFFileName = CurrentPath & CS.Name & ".pdf"
Call SheetToPDF(CS, PDFFileName)

Set CS = Sheets("Northeast")
PDFFileName = CurrentPath & CS.Name & ".pdf"
Call SheetToPDF(CS, PDFFileName)

Set CS = Sheets("Southeast")
PDFFileName = CurrentPath & CS.Name & ".pdf"
Call SheetToPDF(CS, PDFFileName)

Set CS = Sheets("Central")
PDFFileName = CurrentPath & CS.Name & ".pdf"
Call SheetToPDF(CS, PDFFileName)

End Sub

 

[DMJ]

The code posted at the beginning of this thread is for use with PDF995. You need to copy all of the code up to the "Sub PrintToPDF()" routine into a module. Note the items in bold red you will need to update to match the actual file location for the .ini files. "Sub PrintToPDF()" and "Sub PrintCPSheets()" are examples of how to use the SheetToPDF routine to print your pages to PDF. You can use one of these as a template to suit your specific need.


'Needed to Read INI file settings
Declare Function GetPrivateProfileString Lib "kernel32" Alias _
"GetPrivateProfileStringA" (ByVal lpApplicationName As String, _
ByVal lpKeyName As Any, ByVal lpDefault As String, _
ByVal lpReturnedString As String, ByVal nSize As Long, _
ByVal lpFileName As String) As Long

'Needed to Write INI file settings
Declare Function WritePrivateProfileString Lib "kernel32" Alias _
"WritePrivateProfileStringA" (ByVal lpApplicationName As String, _
ByVal lpKeyName As Any, ByVal lpString As Any, _
ByVal lpFileName As String) As Long

Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)


Sub SheetToPDF(WS As Worksheet, OutputFile As String)

' This subroutine will print a worksheet to a PDF file using PDF995, a free utility
' to generate PDF files. Download it at www.pdf995.com

' Two arguments must be passed into this routine
' 1. WS - A worksheet pointer
' 2. OutputFile - The full path and name of the desired pdf file

' Be sure to check that the "Generating PDF CS" setting in pdfsync.ini is set to 0
' when pdf995 is idle. This codes uses that as a completion flag as it seems to be
' the most reliable indication that PDF995 is done writing the pdf file.

Dim syncfile As String, maxwaittime As Long
Dim iniFileName As String 'tmpPrinter As Printer
Dim x As Long
Dim tmpoutputfile As String, tmpAutoLaunch As String

' set the location of the PDF995.ini and the pdfsync files
iniFileName = "c:\pdf995\res\pdf995.ini"
syncfile = "c:\pdf995\res\pdfsync.ini"

' save current settings from the PDF995.ini file
tmpoutputfile = ReadINIfile("PARAMETERS", "Output File", iniFileName)
tmpAutoLaunch = ReadINIfile("PARAMETERS", "Autolaunch", iniFileName)

' remove previous pdf if it exists
On Error Resume Next
Kill OutputFile
On Error GoTo Cleanup

' setup new values in PDF995.ini
x = WritePrivateProfileString("PARAMETERS", "Output File", OutputFile, iniFileName)
x = WritePrivateProfileString("PARAMETERS", "AutoLaunch", "0", iniFileName)

'print the worksheet
WS.Select
ActiveWindow.SelectedSheets.PrintOut Copies:=1, ActivePrinter:="PDF995"

' PDF995 operates asynchronously. We need to determine when it is done so we can
' continue. This is done by checking the "Generating PDF CS" parameter in the pdfsync.ini
' file. A loop with a 2 second delay is used to determine when it is finished.

Sleep (2000) ' pause 2 seconds (1000 = 1 sec)
maxwaittime = 60000 'If pdf995 isn't done in 60 seconds, quit anyway
Do While ReadINIfile("PARAMETERS", "Generating PDF CS", syncfile) = "1" And maxwaittime > 0
Sleep (2000) ' pause 2 seconds and re-check the status
maxwaittime = maxwaittime - 2000
Loop

' restore the original default printer and the PDF995.ini settings
Cleanup:
x = WritePrivateProfileString("PARAMETERS", "Output File", tmpoutputfile, iniFileName)
x = WritePrivateProfileString("PARAMETERS", "AutoLaunch", tmpAutoLaunch, iniFileName)
x = WritePrivateProfileString("PARAMETERS", "Launch", "", iniFileName)
On Error Resume Next


End Sub

Function ReadINIfile(sSection As String, sEntry As String, sFilename As String) As String
Dim x As Long
Dim sDefault As String
Dim sRetBuf As String, iLenBuf As Integer
Dim sValue As String

'Six arguments
'Explanation of arguments:
'sSection: ini file section (always between brackets)
'sEntry : word on left side of "=" sign
'sDefault$: value returned if function is unsuccessful
'sRetBuf$ : the value you're looking for will be copied to this buffer string
'iLenBuf% : Length in characters of the buffer string
'sFileName: Path to the ini file

sDefault$ = ""
sRetBuf$ = String$(256, 0) '256 null characters
iLenBuf% = Len(sRetBuf$)
x = GetPrivateProfileString(sSection, sEntry, _
sDefault$, sRetBuf$, iLenBuf%, sFilename)
ReadINIfile = Left$(sRetBuf$, x)

End Function


Sub PrintToPDF()
' This example prints the first sheet of the workbook. It calls the SheetToPDF subroutine,
' passing it the worksheet pointer, and the PDFFileName (the worksheet name + .pdf)

Dim PDFFileName As String
PDFFileName = "c:\temp\" & Sheets(1).Name & ".pdf"
Call SheetToPDF(Sheets(1), PDFFileName)
End Sub



Sub PrintCPSheets()
' This example prints specific named worksheets. It calls the SheetToPDF subroutine one
' time for each sheet, passing it a worksheet pointer, and PDFFileName.

Dim CS As Worksheet
Dim PDFFileName As String

CurrentPath = "c:\temp\"

Set CS = Sheets("West")
PDFFileName = CurrentPath & CS.Name & ".pdf"
Call SheetToPDF(CS, PDFFileName)

Set CS = Sheets("Northeast")
PDFFileName = CurrentPath & CS.Name & ".pdf"
Call SheetToPDF(CS, PDFFileName)

Set CS = Sheets("Northeast")
PDFFileName = CurrentPath & CS.Name & ".pdf"
Call SheetToPDF(CS, PDFFileName)

Set CS = Sheets("Southeast")
PDFFileName = CurrentPath & CS.Name & ".pdf"
Call SheetToPDF(CS, PDFFileName)

Set CS = Sheets("Central")
PDFFileName = CurrentPath & CS.Name & ".pdf"
Call SheetToPDF(CS, PDFFileName)

End Sub <!-- / message -->

 

[Kathleen0422]

It seems that everything I open this file up (maybe 3 times a year) I need to reset the ini file.

Is there a way through code that puts an on open event that will go out and reset the ini file, without manual intervention?

Thanks for your help

 

[DanBrill]

Hi,

Although this thread is 5 years old, I've found it very useful. Major thanks to SteveF who got the ball rolling. I don't think I would have ever figured out how to read and write to the .ini files without him.

I took his code as an outline and added several new parameters that will enable you to access some of the other features of PDF995. This is working really well for me and I thought others might find it useful.

Thanks,
Dan

'This module works with PDF995 to turn predefined print jobs into PDFs for
'easy saving and e-mailing.

'Needed to Read INI file settings
Declare Function GetPrivateProfileString Lib "kernel32" Alias _
"GetPrivateProfileStringA" (ByVal lpApplicationName As String, _
ByVal lpKeyName As Any, ByVal lpDefault As String, _
ByVal lpReturnedString As String, ByVal nSize As Long, _
ByVal lpFileName As String) As Long

'Needed to Write INI file settings
Declare Function WritePrivateProfileString Lib "kernel32" Alias _
"WritePrivateProfileStringA" (ByVal lpApplicationName As String, _
ByVal lpKeyName As Any, ByVal lpString As Any, _
ByVal lpFileName As String) As Long

Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Sub PrintToPDF_ExampleA()
    Dim WS As String
    Dim OnlySelection As String
    Dim OutputPath As String
    Dim OutputFile As String
    Dim AutoOpenPDF As String
    Dim Combine As String
    
    'The worksheet you want to print. It could be
    'hardcoded, set from value in workbook (using range("Name")
    'or, as I have here, using the active sheet name so that
    'it operates on whatever sheet you start from.
    WS = ActiveSheet.Name
    
    '(I'm defining the parameter variables as strings.  When I
    'tried them as single type, excel kept crashing.  Not sure why.
    'Some worked, others didn't.  Just made them all strings
    'and it seems to work fine.)
    
    'If you want the whole worksheet, set OnlySelection = "0"
    'If you want it to print only selected text, set it to "1"
    'You could setup the selection with another macro if you
    'so desire.
    OnlySelection = "0"
    
    'Set the path where the output goes.  You can hardcode this,
    'or use one of the special windows paths.  Here I call the
    'function UserPath with the parameter "Desktop".  See the
    'end of the module.
    OutputPath = UserPath("Desktop")
    
    'Set the output file name.  Again, this can be hardcoded
    'or you can come up with your own way of programming the
    'value.
    OutputFile = "Example_A"
    
    'Combine the path into a single string
    OutputPath = OutputPath & "\" & OutputFile & ".pdf"

    'Set to "1" if you want the PDF to open after printing, "0" otherwise
    AutoOpenPDF = "1"

    'Set to "1" if you want to append this to the last PDF created
    Combine = "0"

    'Send the parameters to SendToPDF
    Call SendToPDF(WS, OnlySelection, OutputPath, AutoOpenPDF, Combine)
    
End Sub
Sub PrintToPDF_Takeoff()
    Dim WS As String
    Dim OnlySelection As String
    Dim OutputPath As String
    Dim OutputFile As String
    Dim AutoOpenPDF As String
    Dim Combine As String

    'This script is given as an example.
    'It is very specific to what I needed to do in my workbook.
    'It won't work outside of my workbook, but I thought 
    'you might want to follow the code to see how I've customized it.    

    'set the print range
    On Error GoTo NotFound
    Application.ScreenUpdating = False
    
    If Range("c" & ActiveCell.Row).ColumnWidth > 0 Then
        Call ColumnToggle
    End If
    
    Cells.Find(What:="[end of bid]", After:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Activate

    Range("A12:AW" & ActiveCell.Row).Select
    
    WS = "Takeoff" ' this is actually irrelevant if OnlySelection = 1
    OnlySelection = "1"
    
    'in this case I don't need an OutputFile as a filename is
    'already a part of the data in this range.
    OutputPath = Replace(Range("filepath"), ".xls", " - takeoff.pdf")
    
    AutoOpenPDF = "1"
    Combine = "0"
    
    'Send the parameters to SendToPDF
    Call SendToPDF(WS, OnlySelection, OutputPath, AutoOpenPDF, Combine)
    
    Exit Sub
    
NotFound:
    MsgBox "Add an [end of bid] tag."
    
End Sub

Sub SendToPDF(WS As String, OnlySelection As String, OutputPath As String, AutoOpenPDF As String, Combine As String)

    'This is the main workhorse script.
    'All the macros you write will gather up the needed
    'parameters and send them to this one.

    Dim syncfile As String, maxwaittime As Long
    Dim iniFileName As String
    Dim x As Long
    Dim tmpoutputfile As String
    Dim tmpAutoLaunch As String
    Dim tmpCombineDocuments As String
    Dim tmpCombineLast As String
    Dim tmpCombineLastPref As String
    Dim PName As String
        
    'Record the user's current printer
    PName = Application.ActivePrinter
    
    ' set the location of the PDF995.ini and the pdfsync files
    ' Updated to work with newest version of PDF995
    ' You may need to tinker with this depending on your system / network setup
    iniFileName = "c:\program files\pdf995\res\pdf995.ini"
    syncfile = "C:\Documents and Settings\All Users\Application Data\pdf995\pdfsync.ini"
        
    ' save current settings from the PDF995.ini file
    tmpoutputfile = ReadINIfile("PARAMETERS", "Output File", iniFileName)
    tmpAutoLaunch = ReadINIfile("PARAMETERS", "Autolaunch", iniFileName)
    
    tmpCombineDocuments = ReadINIfile("PARAMETERS", "Combine Documents", iniFileName)
    tmpCombineLast = ReadINIfile("PARAMETERS", "Combine Last", iniFileName)
    tmpCombineLastPref = ReadINIfile("PARAMETERS", "Combine Last Preference", iniFileName)
    If tmpCombineLastPref = "" Then tmpCombineLastPref = "0"
      
    
    ' remove previous pdf if it exists
    On Error Resume Next
    Kill OutputFile
    On Error GoTo Cleanup
    
    ' setup new values in PDF995.ini
    x = WritePrivateProfileString("PARAMETERS", "Output File", OutputPath, iniFileName)
    x = WritePrivateProfileString("PARAMETERS", "AutoLaunch", AutoOpenPDF, iniFileName)
    
    x = WritePrivateProfileString("PARAMETERS", "Combine Documents", Combine, iniFileName)
    x = WritePrivateProfileString("PARAMETERS", "Combine Last", Combine, iniFileName)
    x = WritePrivateProfileString("PARAMETERS", "Combine Last Preference", Combine, iniFileName)
    
    'set the printer to PDF995
    'You may have to edit this depending on which port it is set up on.
    'Ne00 is the default setting I believe.
    'Others seem to have had luck with just the "PDF995" but that
    'wasn't working for me.
    Application.ActivePrinter = "PDF995 on Ne00:"

    ' the print command
    If OnlySelection = 0 Then
        Sheets(WS).Select
        ActiveWindow.SelectedSheets.PrintOut Copies:=1
    Else
        Selection.PrintOut Copies:=1, Collate:=True
    End If
        
    'restore the user's active printer
    Application.ActivePrinter = PName
    
    
    ' PDF995 operates asynchronously. We need to determine when it is done so we can
    ' continue. This is done by checking the "Generating PDF CS" parameter in the pdfsync.ini
    ' file. A loop with a 2 second delay is used to determine when it is finished.
    
    Sleep (2000) ' pause 2 seconds (1000 = 1 sec)
    maxwaittime = 60000 'If pdf995 isn't done in 60 seconds, quit anyway
    Do While ReadINIfile("PARAMETERS", "Generating PDF CS", syncfile) = "1" And maxwaittime > 0
    Sleep (2000) ' pause 2 seconds and re-check the status
    maxwaittime = maxwaittime - 2000
    Loop
    
    ' restore the original default printer and the PDF995.ini settings
Cleanup:
    x = WritePrivateProfileString("PARAMETERS", "Output File", tmpoutputfile, iniFileName)
    x = WritePrivateProfileString("PARAMETERS", "AutoLaunch", tmpAutoLaunch, iniFileName)
    
    x = WritePrivateProfileString("PARAMETERS", "Combine Documents", tmpCombineDocuments, iniFileName)
    x = WritePrivateProfileString("PARAMETERS", "Combine Last", tmpCombineLast, iniFileName)
    x = WritePrivateProfileString("PARAMETERS", "Combine Last Preference", tmpCombineLastPref, iniFileName)
    On Error Resume Next

End Sub

Function ReadINIfile(sSection As String, sEntry As String, sFilename As String) As String
Dim x As Long
Dim sDefault As String
Dim sRetBuf As String, iLenBuf As Integer
Dim sValue As String

'Six arguments
'Explanation of arguments:
'sSection: ini file section (always between brackets)
'sEntry : word on left side of "=" sign
'sDefault$: value returned if function is unsuccessful
'sRetBuf$ : the value you're looking for will be copied to this buffer string
'iLenBuf% : Length in characters of the buffer string
'sFileName: Path to the ini file

sDefault$ = ""
sRetBuf$ = String$(256, 0) '256 null characters
iLenBuf% = Len(sRetBuf$)
x = GetPrivateProfileString(sSection, sEntry, _
sDefault$, sRetBuf$, iLenBuf%, sFilename)
ReadINIfile = Left$(sRetBuf$, x)

End Function

Function UserPath(SpecialPath As String) As String

Dim objWSHShell As Object
Set objWSHShell = CreateObject("WScript.Shell")

'set the desired special folder here...
'Unfortunately i can't get this to work with parameters so I'll need a long chain of If-thens

If SpecialPath = "AllUsersDesktop" Then
    UserPath = objWSHShell.SpecialFolders("AllUsersDesktop")
ElseIf SpecialPath = "AllUsersStartMenu" Then
    UserPath = objWSHShell.SpecialFolders("AllUsersStartMenu")
ElseIf SpecialPath = "AllUsersPrograms" Then
    UserPath = objWSHShell.SpecialFolders("AllUsersPrograms")
ElseIf SpecialPath = "AllUsersStartup" Then
    UserPath = objWSHShell.SpecialFolders("AllUsersStartup")
ElseIf SpecialPath = "Desktop" Then
    UserPath = objWSHShell.SpecialFolders("Desktop")
ElseIf SpecialPath = "Favorites" Then
    UserPath = objWSHShell.SpecialFolders("Favorites")
ElseIf SpecialPath = "Fonts" Then
    UserPath = objWSHShell.SpecialFolders("Fonts")
ElseIf SpecialPath = "MyDocuments" Then
    UserPath = objWSHShell.SpecialFolders("MyDocuments")
ElseIf SpecialPath = "NetHood" Then
    UserPath = objWSHShell.SpecialFolders("NetHood")
ElseIf SpecialPath = "PrintHood" Then
    UserPath = objWSHShell.SpecialFolders("PrintHood")
ElseIf SpecialPath = "Programs" Then
    UserPath = objWSHShell.SpecialFolders("Programs")
ElseIf SpecialPath = "Recent" Then
    UserPath = objWSHShell.SpecialFolders("Recent")
ElseIf SpecialPath = "SentTo" Then
    UserPath = objWSHShell.SpecialFolders("SentTo")
ElseIf SpecialPath = "Startmenu" Then
    UserPath = objWSHShell.SpecialFolders("StartMenu")
ElseIf SpecialPath = "Startup" Then
    UserPath = objWSHShell.SpecialFolders("Startup")
ElseIf SpecialPath = "Templates" Then
    UserPath = objWSHShell.SpecialFolders("Templates")
End If

'clean up...
Set objWSHShell = Nothing

End Function