I am using PDF995 to create PDF's of my Excel worksheets. Unfortunately, I am experiencing a strange issue where the generated document is black and white when my default printer is one other than PDF995 prior to running my application. If the default printer is set to PDF995 prior to running my application, the generated PDF is in color as expected. My print function does set the default printer. Below are the relevant sections of the code:
edit: Adding missing functions
I've contacted PDF995 support and they insist that this is not a problem with there software. Considering this only occurs when it is used from my application, I cannot really argue with them.
Please note that there is no API for PDF995 and I have to accomplish a lot by manipulating its INI file. Just in case you were wondering ...
Rich (BB code):
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare Function setDefaultPrinter Lib "winspool.drv" Alias "SetDefaultPrinterA" (ByVal pszPrinter As String) As Long
Private Declare Function GetDefaultPrinter Lib "winspool.drv" Alias "GetDefaultPrinterA" (ByVal sPrinterName As String, lPrinterNameBufferSize As Long) As Long
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
Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal sSectionName As String, ByVal sKeyName As String, ByVal sString As String, ByVal sFileName As String) As Long
Const MAX_WAIT As Integer = 10000
Const MAX_PDFFILENUM As Integer = 1000
Const PDF995_REGKEY As String = "HKEY_LOCAL_MACHINE\SOFTWARE\PDF995\PATH"
' Error messages
Const ERR_NO_PDF995 As String = "Cannot find PDF995 on your computer. Please install PDF995 and try again."
Const ERR_NO_PDF995INI As String = "Missing pdf995.ini file."
Const ERR_NO_PDFEDIT As String = "Cannot find PDFEdit995 on your computer. Please install PDF995Edit and try again."
Dim m_MergeEXE As String
Dim m_PDF995Root As String
Dim m_INI As String
Rich (BB code):
Public Function PrintRangeToPDF(sRange As Range, Optional iCopies As Integer = 1, Optional sPrinter As String = "PDF995", Optional iLayout As Integer = 0) As String
Dim DefPrinter As String 'Variable to hold original default printer
Dim sLen As Long 'Variable that will hold the length of printer string
Dim hResult As Long 'Holds result of GetDefaultPrinter
Dim sErr As String
If verifyPDF995(sErr) Then
DefPrinter = Space$(255)
sLen = 255
hResult = GetDefaultPrinter(ByVal DefPrinter, sLen)
If hResult <> 0 Then
setPDF995Layout (iLayout)
DefPrinter = Left(DefPrinter, sLen - 1)
setDefaultPrinter sPrinter
sRange.PrintOut Copies:=iCopies
waitForPDF
setDefaultPrinter DefPrinter
End If
Else
PrintRangeToPDF = sErr
End If
End Function
Rich (BB code):
Public Function verifyPDF995(ByRef sErr As String) As Boolean
On Error GoTo PDF995Err:
m_PDF995Root = RegKeyRead(PDF995_REGKEY)
If m_PDF995Root = "" Then
sErr = ERR_NO_PDF995
verifyPDF995 = False
Exit Function
End If
m_INI = m_PDF995Root & "pdf995\res\pdf995.ini"
m_MergeEXE = m_PDF995Root & "pdf995\res\utilities\pdfcombine.exe"
If Dir(m_MergeEXE) = "" Then
sErr = ERR_NO_PDFEDIT
verifyPDF995 = False
Exit Function
End If
' Make sure proper entries exist in the PDF995 INI file.
If GetSectionEntry("Parameters", "Output File", m_INI) = vbNullChar Or Not IsNumeric(GetSectionEntry("Parameters", "Output File", m_INI)) Then
SetSectionEntry "Parameters", "Output File", m_INI, 1
End If
If GetSectionEntry("Parameters", "Quiet", m_INI) <> "0" Then
SetSectionEntry "Parameters", "Quiet", m_INI, 0
End If
' Get the starting PDF document number
m_StartPDF = CInt(GetSectionEntry("Parameters", "Output File", m_INI))
'we do however; need to set the value if it doesn't exist.
If m_StartPDF = vbNullChar Then
SetSectionEntry "Parameters", "Output File", m_INI, 1
m_StartPDF = 1
End If
verifyPDF995 = True
Exit Function
PDF995Err:
sErr = Err.Description
verifyPDF995 = False
Err.Clear
End Function
Rich (BB code):
Public Sub waitForPDF()
Dim sFile As String
Dim iCount As Integer
Dim lastFileLen As Long
On Error Resume Next
' always wait 2 seconds first. this ensures that we're waiting for the correct file.
Sleep (2000)
sFile = GetSectionEntry("Parameters", "User File", m_INI)
If Trim(sFile) = "" Then
sFile = GetSectionEntry("Parameters", "Output Folder", m_INI) & "\" & CInt(GetSectionEntry("Parameters", "Output File", m_INI)) - 1 & ".pdf"
End If
lastFileLen = FileLen(sFile)
DoEvents
Sleep (100)
While ((FileLen(sFile) <> lastFileLen) Or FileLen(sFile) = 0) And iCount < MAX_WAIT
DoEvents
lastFileLen = FileLen(sFile)
Sleep (2000)
iCount = iCount + 2000
Wend
End Sub
Rich (BB code):
Private Sub setPDF995Layout(iLayout As Integer)
SetSectionEntry "Parameters", "Rotate Pages", m_INI, iLayout
If iLayout = 1 Then
SetSectionEntry "Parameters", "Rotation Degrees", m_INI, 90
End If
End Sub
Rich (BB code):
Public Function GetSectionEntry(ByVal strSectionName As String, ByVal strEntry As String, ByVal strIniPath As String) As String
'found at http://vbadud.blogspot.com/2008/11/how-to-read-and-write-configuration.html
'===================================================================================
'Purpose : Retrieve data from Sample.ini
'Assumptions:
'Effects :
'Inputs : Section Name and Entry Name in the KitBOM ini
'Returns : Value of the Entry in the section
'===================================================================================
Dim x As Long
Dim sSection As String, sEntry As String, sDefault As String
Dim sRetBuf As String, iLenBuf As Integer, sFileName As String
Dim sValue As String
On Error GoTo ErrGetSectionentry
sSection = strSectionName
sEntry = strEntry
sDefault = ""
sRetBuf = Strings.String$(256, 0) '256 null characters
iLenBuf = Len(sRetBuf$)
sFileName = strIniPath
x = GetPrivateProfileString(sSection, sEntry, "", sRetBuf, iLenBuf, sFileName)
sValue = Strings.Trim(Strings.Left$(sRetBuf, x))
If sValue <> "" Then
GetSectionEntry = sValue
Else
GetSectionEntry = vbNullChar
End If
ErrGetSectionentry:
If Err <> 0 Then
Err.Clear
Resume Next
End If
End Function
Rich (BB code):
Public Function SetSectionEntry(ByVal strSectionName As String, ByVal strEntry As String, ByVal strIniPath As String, ByVal strValue As String)
' Write Data to Ini File
SetSectionEntry = WritePrivateProfileString(strSectionName, strEntry, strValue, strIniPath)
End Functionedit: Adding missing functions
Rich (BB code):
' found these registry functions at: http://vba-corner.livejournal.com/3054.html
'reads the value for the registry key i_RegKey
'if the key cannot be found, the return value is ""
Function RegKeyRead(sRegKey As String) As String
Dim myWS As Object
On Error Resume Next
If RegKeyExists(sRegKey) Then
'access Windows scripting
Set myWS = CreateObject("WScript.Shell")
'read key from registry
RegKeyRead = myWS.RegRead(sRegKey)
Set myWS = Nothing
End If
End Function
Function RegKeyExists(sRegKey As String) As Boolean
Dim myWS As Object
On Error GoTo ErrorHandler
'access Windows scripting
Set myWS = CreateObject("WScript.Shell")
'try to read the registry key
myWS.RegRead sRegKey
'key was found
RegKeyExists = True
Set myWS = Nothing
Exit Function
ErrorHandler:
'key was not found
RegKeyExists = False
Set myWS = Nothing
End FunctionPlease note that there is no API for PDF995 and I have to accomplish a lot by manipulating its INI file. Just in case you were wondering ...
Last edited:
