RE/
However what then happens is: a ?Save File As' dialog box appears,
prompts me to click on ?OK' and when I do, the report is created and
saved, but Adobe then open the report. I want my code to be able to
override this dialog box and automatically save the report with a file
name I put in a variable, and stop Adobe from opening at the end.
I have looked at using the properties in Adobe but they don't seem to
help.
Is what I want to do possible? I don't know and unfortunately I work
for a large organisation and have to use Adobe and no other product ?
free or not.
Assuming that all users have PdfWriter (couple hundred dollars per seat)
installed on their PC's, what you do is use the registry as your interface to
Acrobat. You set parms for file name and a couple other things and then just
let it rip.
Here's some code that includes handling .PDF. It's a class and is probably
wretched excess for what you want to do...but the code is there TB teased out as
needed. What's missing is the code to look at the user's printers and figure
out whether PdfWriter is available. I do that outside of the class BC I use
the results to enable/disable the "PDF" button/option on the screen in question.
If it looks promising, let me know and we'll figure out a way for me to email it
as an attachment - since our respective email programs have probably made hash
out of the line breaks...
=============== =============== =============== =============== =============== =====
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "clsReportPrint er"
Attribute VB_GlobalNameSp ace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredI d = False
Attribute VB_Exposed = False
Option Compare Database ' Next available line# series = 8000
Option Explicit
Private Const mVersionNumber = "2.1c" 'Rearranged Types/Constants:
wasn't compiling after decompile because definition of constant didn't preceede
use of same.
Private Const mModuleName = "clsReportPrint er"
' PURPOSE: To provide a way to print MS Access reports to named printers
' and to coerce output characteristics like paper size and
orientation.
'
' Also enables batch printing to Adobe's PDF Writer by supressing
' it's common file dialog and programaticaly supplying file paths.
'
' Intended particularly for batch operations in which
' we need to print many reports, typically looping through
' a work table that contains names of reports to be printed
' along with desired paper size, orientation, and copies.
'
' Also intended to address a recurrant problem in which
' a user changes their system default printer and any reports
' that are set up for, say, legal/landscape, automatically revert
' to the new printer's default settings (usually letter/portrait).
'
' ERRORS: - All error checking is postponed until the calling app invokes
the .PrintReport method.
' After the .PrintReport method has been invoked, the calling app
is responsible for checking
' the .ErrorCount property and displaying .ErrorList if there are
any errors.
' - All errors are 'Fatal' in that no printing will take place if
there is even a single error.
' - Error messages may be sent to up to three places
' > All errors get written to the .ErrorList property, which is
available to the calling
' app once the .PrintReport method has been invoked.
' > Runtime/program errors also bubble up to the calling routine
as trappable errors
' > Runtime/program errors also get written to a log file in the
same directory as the
' calling application unless the user specifies another path via
the .ErrorLogPath property
' - If no printer is installed on the PC, only that condition is
reported, but all other checking
' is suppressed.
'
' METHODS: .PrintReport Causes report to be printed once all needed
properties are set
'
' PROPERTIES
' REQUIRED: -> .ReportName String containing name of report to be printed
' OPTIONAL:
' -> .PdfDir A path to the directory into which a .PDF file
' will be written to. Should NOT include the
name of the file.
' Defaults to application directory.
' e.g. C:\TEMP is correct. C:\TEMP\Whateve r.PDF
is incorrect.
' -> .PrinterName String containing the UNC of the printer. If
not supplied,
' PC's default printer is used. If no default
printer, an error
' is reported.
' -> .ErrorLogPath String telling where to write error log for
program errors
' seldom actually used, since most errors are data
errors and written
' to the .ErrorList....u seful, however, in case
the the code generates
' a runtime error and you want a record. Runtime
errors also
' bubble up to the calling routine where they can
be trapped/displayed.
' Defaults to application directory.
' -> (Any and all parameters used in setting up a printer. e.g.
..Copies,
' .Orientation, .PaperSize, and so-forth.)
' Refer to Appendix A of documentation for
details.
' READ-ONLY:
' <- .ErrorCount Numeric containing the number (if any) of errors
encountered.
' If .ErrorCount>0, the report did not get printed
' <- .ErrorList String containing a description of each error
encountered.
'
' =============== > NEED MORE PROPERTY DESCRIPTIONS
<============== =====
'
'
' DEFAULTS (set in Class_Initializ e):
' .PrinterName=(n ame of PC's 'Default' printer)
' .Collate=False
' .Copies=1
' .Color=Monochro me
' .DefaultSource= Auto
' .Duplex=Simplex
' .GetPdfFileName From=Report's Caption
' .Orientation=Po rtrait
' .PaperSize=Lett er
' .PdfDir=(applic ation's directory)
' .PrinterName=PC 's default printer
' .PrintQuality=H igh
'
' REQUIRES: - A reference to 'Microsoft Active-X Data Objects 2.1 Library'
'
' NOTES: 1) While the class is having properties assigned, it will accept
just about anything
' for any property. All of the validation is done when the
..PrintReport method is invoked.
'
' HOW TO USE: 1) Getting it into your app:
' - Open up a code window by doubleclicking one of the modules
' - Use File/Import File to import clsReportPrinte r.cls
' NB: Importing directly from another Access app will NOT
work...
' ...somethng to do with invisible header information that
gets
' lost when importing from an Access app...must be imported
from
' a text file.
' - Do a Debug/Compile to make sure everyting is OK.
'
' 2) Invoking it to print a report:
' - The clsReportPrinte r object can be instantiated once, and
then used to print many reports.
' - Sample code for printing the same report four times using
different options,
' and then printing a second report:
'
'
=============== =============== =============== =============== =========
' Sub ReportPrintExam ple()
'
' Dim myReportPrinter As clsReportPrinte r
'
' Set myReportPrinter = New clsReportPrinte r
'
' With myReportPrinter
' .ReportName = "rptBillableHou rsByDay"
' .PrintReport 'Report goes to
default printer in default orientation (portrait)
' If .ErrorCount > 0 Then 'using report's
..Caption for file name if default is PDF Writer.
' MsgBox .ErrorList, vbCritical, "Print Failed"
' End If
'
' .PrinterName = "Acrobat PDFWriter"
' .PdfDir = "C:\Temp"
' .GetPdfFileName From = rpGetFromReport Name
' .PrintReport 'Report goes to
..PDF file using report's object name as file name.
' If .ErrorCount > 0 Then
' MsgBox .ErrorList, vbCritical, "Print Failed"
' End If
'
' .GetPdfFileName From = rpGetFromReport Caption
' .LaunchAcrobat = True 'Report goes to
..PDF file using report's .Caption name as file name
' .PrintReport 'and Acrobat is
opened to show report.
' If .ErrorCount > 0 Then
' MsgBox .ErrorList, vbCritical, "Print Failed"
' End If
'
' .PrinterName = "\\NtPrt41\Invs tPrt"
' .Copies = 2
' .Orientation = rpOrient_Landsc ape
' .PrintReport 'Two copies of
report go to specified printer in landscape orientation.
' If .ErrorCount > 0 Then
' MsgBox .ErrorList, vbCritical, "Print Failed"
' End If
'
' .ReportName = "rptVanguardTim eSheet" 'As above, two
copies go to specified printer in landscape orientation
' .PrintReport 'because .Copies,
..PrinterName, and .Orientation are still set.
' End With
'
' On Error Resume Next
' Set myReportPrinter = Nothing
' Exit Sub
' End Sub
'
=============== =============== =============== =============== =========
'
' Pete Cresswell
' 03/22/2001
' 610-513-0066
Private Const mPdfPrinterName = "Acrobat PDFWriter" 'SB exactly the same as
name that shows up in "myComputer/Printers"
Private Const adhcMaxDevice = 32
Private Const adhcDevNamesFix ed = 8
Private Const adhcFixedChars = adhcDevNamesFix ed / 2
Private Const mDriverStringLe nBinName = 24
Private Const mDriverStringLe nPaperName = 64
Private Const mDriverStringLe nBinDependency = 64
Private Const mFormNameLen = 32
Private Const mPrinterNameLen = 32
'Private Const mCallStackLim = 50
Private Const mCallStackLim = 150
Private mCallStack(mCal lStackLim)
Private mCallStackPoint er As Integer
Private Const mErrorListMessa gePrefix = "- "
Private Const mDevModeFudgeFa ctor = 2048
Private Const mDevModeSize = 148
Private Const mDevModeSizeLim = mDevModeSize + mDevModeFudgeFa ctor
Private Type mPrinterStruct
IsDefaultPrinte r As Boolean
DeviceName As String
DriverName As String
Port As String
End Type
Private Type mPrtDevModeStru ct
strDeviceName(1 To mPrinterNameLen ) As Byte
intSpecVersion As Integer
intDriverVersio n As Integer
intSize As Integer
intDriverExtra As Integer
lngFields As Long
intOrientation As Integer
intPaperSize As Integer
intPaperLength As Integer
intPaperWidth As Integer
intScale As Integer
intCopies As Integer
intDefaultSourc e As Integer
intPrintQuality As Integer
intColor As Integer
intDuplex As Integer
intYResolution As Integer
intTTOption As Integer
intCollate As Integer
strFormName(1 To mFormNameLen) As Byte
intLogPixels As Integer
lngBitsPerPixel As Long
lngPelsWidth As Long
lngPelsHeight As Long
lngDisplayFlags As Long
lngDisplayFrequ ency As Long
lngICMMethod As Long
lngICMIntent As Long
lngMediaType As Long
lngDitherType As Long
lngReserved1 As Long
lngReserved2 As Long
bytDriverExtra( 1 To mDevModeFudgeFa ctor) As Byte
End Type
Private Type mDevModeStringS truct
strDevMode As String * mDevModeSizeLim
End Type
Private Type mDevNamesOffset InfoStruct
DriverOffset As Integer
DeviceOffset As Integer
OutputOffset As Integer
IsDefaultPrinte r As Integer
End Type
Private Type mDevNamesOffset StringStruct
strDevInfo As String * adhcFixedChars
End Type
Private Type mDoubleWordStru ct
Value As Long
End Type
Private Type mSplitWordStruc t
LoWord As Integer
HiWord As Integer
End Type
Private Type mXyPoint
x As Long
Y As Long
End Type
Public Enum rpDmBitFields ' Constants for Bitfields for the
Fields member of the DevMode structure.
rp_Color = &H800
rp_Collate = &H8000
rp_Copies = &H100
rp_DefaultSourc e = &H200
rp_Duplex = &H1000
rp_Orientation = &H1
rp_PaperLength = &H4
rp_PaperSize = &H2
rp_PaperWidth = &H8
rp_PrintQuality = &H400
rp_Scale = &H10
rp_Y_Resolution = &H2000
' rp_T_Option = &H4000
End Enum
'Private Enum dmTrueType
' DMTT_BITMAP = 1
' DMTT_DOWNLOAD = 2
' DMTT_SUBDEV = 4
' DMTT_DOWNLOAD_O UTLINE = 8
'End Enum
'Private mlngTT As dmTrueType
Public Enum rpCollate ' Constants for Collate property
rpCollate_True = 1
rpCollate_False = 0
End Enum
Public Enum rpColor ' Constants for Color property
rpColor_Monochr ome = 1
rpColor_Color = 2
End Enum
Public Enum rpDefaultSource ' Constants for DefaultSource
property
rpSrc_Upper = 1
rpSrc_OnlyOne = 1
rpSrc_Lower = 2
rpSrc_Middle = 3
rpSrc_Manual_Fe ed = 4
rpSrc_Envelope = 5
rpSrc_Envelope_ Manual_Feed = 6
rpSrc_Auto = 7
rpSrc_Tractor = 8
rpSrc_Small_For mat = 9
rpSrc_Large_For mat = 10
rpSrc_Large_Cap acity = 11
rpSrc_Cassette = 14
rpSrc_Form_Sour ce = 15
rpSrc_User = 256
End Enum
Public Enum rpDuplex ' Constants for Duplex property
rpDuplex_Simple x = 1
rpDuplex_Vertic al = 2
rpDuplex_Horizo ntal = 3
End Enum
Public Enum rpGetPdfFileNam eFrom
rpGetFromReport Name = 1
rpGetFromReport Caption = 2
End Enum
Public Enum rpOrientation ' Constants for Orientation
property
rporient_Portra it = 1
rporient_landsc ape = 2
End Enum
Public Enum rpPaperSize ' Constants for PaperSize property
rpPaper_Letter = 1 ' Letter 8 1/2 x 11
rpPaper_LetterS mall = 2 ' Letter Small 8 1/2 x 11
rpPaper_Tabloid = 3 ' Tabloid 11 x 17
rpPaper_Ledger = 4 ' Ledger 17 x 11
rpPaper_Legal = 5 ' Legal 8 1/2 x 14
rpPaper_Stateme nt = 6 ' Statement 5 1/2 x 8 1/2
rpPaper_Executi ve = 7 ' Executive 7 1/4 x 10 1/2
rpPAPER_A3 = 8 ' A3 297 x 420 mm
rpPaper_A4 = 9 ' A4 210 x 297 mm
rpPaper_A4_Smal l = 10 ' A4 Small 210 x 297 mm
rpPaper_A5 = 11 ' A5 148 x 210 mm
rpPaper_B4 = 12 ' B4 (JIS) 250 x 354 mm
rpPaper_B5 = 13 ' B5 (JIS) 182 x 257 mm
rpPaper_FOLIO = 14 ' Folio 8 1/2 x 13
rpPaper_QUARTO = 15 ' Quarto 215 x 275 mm
rpPaper_10X14 = 16 ' 10x14 in
rpPaper_11X17 = 17 ' 11x17 in
rpPaper_NOTE = 18 ' Note 8 1/2 x 11 in
rpPaper_Env_9 = 19 ' Envelope #9 3 7/8 x 8 7/8
rpPaper_Env_10 = 20 ' Envelope #10 4 1/8 x 9 1/2
rpPaper_Env_11 = 21 ' Envelope #11 4 1/2 x 10 3/8
rpPaper_Env_12 = 22 ' Envelope #12 4 \276 x 11
rpPaper_Env_14 = 23 ' Envelope #14 5 x 11 1/2
rpPaper_C_Sheet = 24 ' C size sheet
rpPaper_D_Sheet = 25 ' D size sheet
rpPaper_E_Sheet = 26 ' E size sheet
rpPaper_Env_DL = 27 ' Envelope DL 110 x 220mm
rpPaper_Env_C5 = 28 ' Envelope C5 162 x 229 mm
rpPaper_Env_C3 = 29 ' Envelope C3 324 x 458 mm
rpPaper_Env_C4 = 30 ' Envelope C4 229 x 324 mm
rpPaper_Env_C6 = 31 ' Envelope C6 114 x 162 mm
rpPaper_Env_C65 = 32 ' Envelope C65 114 x 229 mm
rpPaper_Env_B4 = 33 ' Envelope B4 250 x 353 mm
rpPaper_Env_B5 = 34 ' Envelope B5 176 x 250 mm
rpPaper_Env_B6 = 35 ' Envelope B6 176 x 125 mm
rpPaper_Env_ITA LY = 36 ' Envelope 110 x 230 mm
rpPaper_Env_Mon arch = 37 ' Envelope Monarch 3.875 x 7.5
rpPaper_Env_Per sonal = 38 ' Envelope 3 5/8 x 6 1/2
rpPaper_FanFold _US = 39 ' US Std Fanfold 14 7/8 x 11
rpPaper_FanFold _Std_German = 40 ' German Std Fanfold 8 1/2 x 12
rpPaper_FanFold _Lgl_German = 41 ' German Legal Fanfold 8 1/2 x 13
rpPaper_ISO_B4 = 42 ' B4 (ISO) 250 x 353 mm
rpPaper_Japanes e_Postcard = 43 ' Japanese Postcard 100 x 148 mm
rpPaper_9X11 = 44 ' 9 x 11
rpPaper_10X11 = 45 ' 10 x 11
rpPaper_15X11 = 46 ' 15 x 11
rpPaper_Env_Inv ite = 47 ' Envelope Invite 220 x 220 mm
rpPaper_Reserve d_48 = 48 ' RESERVED--DO NOT USE
rpPaper_Reserve d_49 = 49 ' RESERVED--DO NOT USE
rpPaper_Letter_ Extra = 50 ' Letter Extra 9 x 12
rpPaper_LEGAL_E xtra = 51 ' Legal Extra 9 x 15
rpPaper_Tabloid _Extra = 52 ' Tabloid Extra 11.69 x 18
rpPaper_A4_Extr a = 53 ' A4 Extra 9.27 x 12.69
rpPaper_Letter_ Transverse = 54 ' Letter Transverse 8 \275 x 11
rpPaper_A4_Tran sverse = 55 ' A4 Transverse 210 x 297 mm
rpPaper_Letter_ Extra_Transvers e = 56 ' Letter Extra Transverse 9\275 x
12
rpPaper_A_Plus = 57 ' SuperA/SuperA/A4 227 x 356 mm
rpPaper_B_Plus = 58 ' SuperB/SuperB/A3 305 x 487 mm
rpPaper_Letter_ Plus = 59 ' Letter Plus 8.5 x 12.69
rpPaper_A4_Plus = 60 ' A4 Plus 210 x 330 mm
rpPaper_A5_Tran sverse = 61 ' A5 Transverse 148 x 210 mm
rpPaper_B5_Tran sverse = 62 ' B5 (JIS) Transverse 182 x 257 mm
rpPaper_A3_Extr a = 63 ' A3 Extra 322 x 445 mm
rpPaper_A5_Extr a = 64 ' A5 Extra 174 x 235 mm
rpPaper_B5_Extr a = 65 ' B5 (ISO) Extra 201 x 276 mm
rpPaper_A2 = 66 ' A2 420 x 594 mm
rpPaper_A3_Tran sverse = 67 ' A3 Transverse 297 x 420 mm
rpPaper_A3_Extr a_Transverse = 68 ' A3 Extra Transverse 322 x 445 mm
rpPaper_User = 256 ' ?????
End Enum
Public Enum rpPrintQuality ' Constants for PrintQuality property
rpQual_Draft = -1
rpQual_Low = -2
rpQual_Medium = -3
rpQual_High = -4
End Enum
'Public Enum rpTrueType
' rpTT_BitMap = 1
' rpTT_DownLoad = 2
' rpTT_DubDev = 3
' rpTT_DownLoad_O utline = 4
'End Enum
Private mCurView As Integer
Private mCurPdfDir As String
Private mCurFilter As String
Private mCurDevMode As mPrtDevModeStru ct
Private mCurErrorList As String
Private mCurPrinters() As mPrinterStruct 'The class's list of all
printers installed on this PC
Private mCurErrorCount As Long
Private mCurReportName As String
Private mCurPrinterName As String
Private mCurErrorLogPat h As String
Private mCurLaunchAcrob at As Boolean
Private mCurGetPdfFileN ameFrom As Long
Private mCurShowPdfRegi stryInfo As Boolean
Private mCurReportFileN amePrefix As String
Private mCurReportFileN ameSuffix As String
Public Enum rpView
rpViewNormal = acViewNormal
rpViewPreview = acViewPreview
End Enum
Private Declare Function ClosePrinter Lib "winspool.d rv" (ByVal hPrinter As
Long) As Long
Private Declare Function DocumentPropert ies Lib "winspool.d rv" Alias
"DocumentProper tiesA" (ByVal hwnd As Long, ByVal hPrinter As Long, ByVal
pDeviceName As String, pDevModeOutput As Byte, pDevModeInput As Byte, ByVal
fMode As Long) As Long
Private Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNam eA"
(ByVal lpBuffer As String, nSize As Long) As Long
Private Declare Function GetProfileSecti on Lib "kernel32" Alias
"GetProfileSect ionA" (ByVal lpAppName As String, ByVal lpReturnedStrin g As
String, ByVal lngSize As Long) As Long
Private Declare Function GetProfileStrin g Lib "kernel32" Alias
"GetProfileStri ngA" (ByVal lpAppName As String, ByVal lpKeyName As String, ByVal
lpDefault As String, ByVal lpReturnedStrin g As String, ByVal nSize As Long) As
Long
Private Declare Function GetUserName Lib "advapi32.d ll" Alias "GetUserNam eA"
(ByVal lpBuffer As String, nSize As Long) As Long
Private Declare Function OpenPrinter Lib "winspool.d rv" Alias "OpenPrinte rA"
(ByVal pPrinterName As String, phPrinter As Long, ByVal pDefault As Long) As
Long
Private Declare Function DeviceCapabilit iesAny Lib "winspool.d rv" Alias
"DeviceCapabili tiesA" (ByVal strDeviceName As String, ByVal strPort As String,
ByVal lngIndex As Long, lpOutput As Any, ByVal lngDevMode As Long) As Long
Private Declare Function DeviceCapabilit iesLng Lib "winspool.d rv" Alias
"DeviceCapabili tiesA" (ByVal strDeviceName As String, ByVal strPort As String,
ByVal lngIndex As Long, ByVal lngOutput As Long, ByVal lngDevMode As Long) As
Long
Private Declare Function DeviceCapabilit iesStr Lib "winspool.d rv" Alias
"DeviceCapabili tiesA" (ByVal strDeviceName As String, ByVal strPort As String,
ByVal lngIndex As Long, ByVal strOutput As String, ByVal lngDevMode As Long) As
Long
Private Enum mDeviceCapabili tyTypes ' Constants for Device Capabilities
dcFields = 1
dcPapers = 2
dcPapersize = 3
dcMinExtent = 4
dcMaxExtent = 5
dcBins = 6
dcDuplex = 7
dcSize = 8
dcExtra = 9
dcVersion = 10
dcDriver = 11
dcBinNames = 12
dcEnumResolutio ns = 13
dcFileDependenc ies = 14
dcTrueType = 15
dcPaperNames = 16
dcOrientation = 17
dcCopies = 18
End Enum
Private Declare Function RegCloseKey Lib "advapi32.d ll" (ByVal lngHKey As Long)
As Long
Private Declare Function RegCreateKeyEx Lib "advapi32.d ll" Alias
"RegCreateKeyEx A" (ByVal lngHKey As Long, ByVal lpSubKey As String, ByVal
Reserved As Long, ByVal lpClass As String, ByVal dwOptions As Long, ByVal
samDesired As Long, ByVal lpSecurityAttri butes As Long, phkResult As Long,
lpdwDisposition As Long) As Long
Private Declare Function RegOpenKeyEx Lib "advapi32.d ll" Alias "RegOpenKey ExA"
(ByVal lngHKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal
samDesired As Long, phkResult As Long) As Long
Private Declare Function RegQueryValueEx A Lib "advapi32.d ll" (ByVal lngHKey As
Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long,
ByVal lpData As Long, lpcbData As Long) As Long
Private Declare Function RegQueryValueEx Long Lib "advapi32.d ll" Alias
"RegQueryValueE xA" (ByVal lngHKey As Long, ByVal lpValueName As String, ByVal
lpReserved As Long, lpType As Long, lpData As Long, lpcbData As Long) As Long
Private Declare Function RegQueryValueEx String Lib "advapi32.d ll" Alias
"RegQueryValueE xA" (ByVal lngHKey As Long, ByVal lpValueName As String, ByVal
lpReserved As Long, lpType As Long, ByVal lpData As String, lpcbData As Long) As
Long
Private Declare Function RegSetValueExLo ng Lib "advapi32.d ll" Alias
"RegSetValueExA " (ByVal lngHKey As Long, ByVal lpValueName As String, ByVal
Reserved As Long, ByVal dwType As Long, lpValue As Long, ByVal cbData As Long)
As Long
Private Declare Function RegSetValueExSt ring Lib "advapi32.d ll" Alias
"RegSetValueExA " (ByVal lngHKey As Long, ByVal lpValueName As String, ByVal
Reserved As Long, ByVal dwType As Long, ByVal lpValue As String, ByVal cbData As
Long) As Long
'Private Const mRegHKeyClasses Root = &H80000000
'Private Const mRegHKeyLocalMa chine = &H80000002
Private Const mRegHKeyCurrent User = &H80000001
Private Const mPdfWriterKeyNa me = "Software\Adobe \Acrobat PDFWriter"
Private Const mRegOptionNonVo latile = 0
Private Const mRregKeyAllAcce ss = &H3F
Private Const mRegSz As Long = 1
Private Const mRegDWord As Long = 4
Private Const mRegKeyQueryVal ue = &H1
'
Private Sub Class_Initializ e()
callStackPush mModuleName, "Class_Initiali ze"
On Error GoTo catchError
' PURPOSE: - To populate the class's collection of all printers on this PC
' - To make sure we have at least one printer installed
' - To set any default values for properties
'
' NOTES: 1) The assumption is that if there is no default printer, no printers
are installed.
printerArrayLoa d
mCurView = rpViewNormal
mCurPdfDir = extractDirFromF ullPath(Applica tion.CurrentDb. Name)
mCurPrinterName = printerDefaultG et.DeviceName
mCurGetPdfFileN ameFrom = rpGetFromReport Caption
If Len(mCurPrinter Name) = 0 Then
errorListAdd "No printer is installed on this PC. Cannot print until at
least one printer is installed."
Else
With mCurDevMode
.intCollate = rpCollate_False
.intCopies = 1
.intColor = rpColor_Monochr ome
.intDefaultSour ce = rpSrc_Auto
.intDuplex = rpDuplex_Simple x
.intOrientation = rporient_Portra it
.intPaperSize = rpPaper_Letter
.intPrintQualit y = rpQual_High
End With
End If
Xit:
callStackPop
On Error Resume Next
Exit Sub
catchError:
errorLogWrite ""
Resume Xit
End Sub
Public Property Get ErrorCount() As Long
callStackPush mModuleName, "ErrorCount "
On Error GoTo catchError
' PURPOSE: - To allow the using routine to check for errors.
' RETURNS: Count of errors
ErrorCount = mCurErrorCount
Xit:
callStackPop
On Error Resume Next
Exit Property
catchError:
errorLogWrite ""
Resume Xit
End Property
Public Property Get ErrorList() As String
callStackPush mModuleName, "ErrorList"
On Error GoTo catchError
' PURPOSE: - To allow the using routine to display error messages
' RETURNS: Error messages
ErrorList = mCurErrorList
Xit:
callStackPop
On Error Resume Next
Exit Function
catchError:
errorLogWrite ""
Resume Xit
End Property
Public Property Let GetPdfFileNameF rom(ByVal theValue As rpGetPdfFileNam eFrom)
callStackPush mModuleName, "GetPdfFileName From"
On Error GoTo catchError
' PURPOSE: To allow the calling routine to specify whether to use
' report's .Caption or object name when creating PDF file name.
mCurGetPdfFileN ameFrom = theValue
Xit:
callStackPop
On Error Resume Next
Exit Property
catchError:
errorLogWrite ""
Resume Xit
End Property
Public Property Let ReportName(ByVa l theValue As String)
callStackPush mModuleName, "ReportName "
On Error GoTo catchError
' PURPOSE: - To allow the using routine to set the name of the report to be
printed
' ACCEPTS: Name of the Report
mCurReportName = theValue
Xit:
callStackPop
On Error Resume Next
Exit Property
catchError:
errorLogWrite ""
Resume Xit
End Property
Public Property Let PdfDir(ByRef theValue As String)
callStackPush mModuleName, "PdfDir"
On Error GoTo catchError
' PURPOSE: - To allow the using routine to set the class' PDF directory
' ACCEPTS: String specifying full path to which any .PDF file should be
' written. Does *not* contain file name. e.g. C:\TEMP
mCurPdfDir = theValue
Xit:
callStackPop
On Error Resume Next
Exit Property
catchError:
errorLogWrite ""
Resume Xit
End Property
Public Property Let ReportFileNameP refix(ByRef theValue As String)
callStackPush mModuleName, "ReportFileName Prefix"
On Error GoTo catchError
' PURPOSE: - To allow the using routine to supply a string to be appended before
' each report's PDF file name
' ACCEPTS: String specifying the prefix
mCurReportFileN amePrefix = theValue
Xit:
callStackPop
On Error Resume Next
Exit Property
catchError:
errorLogWrite ""
Resume Xit
End Property
Public Property Let ReportFileNameS uffix(ByRef theValue As String)
callStackPush mModuleName, "ReportFileName Suffix"
On Error GoTo catchError
' PURPOSE: - To allow the using routine to supply a string to be appended after
' each report's PDF file name
' ACCEPTS: String specifying the suffix
mCurReportFileN ameSuffix = theValue
Xit:
callStackPop
On Error Resume Next
Exit Property
catchError:
errorLogWrite ""
Resume Xit
End Property
Public Property Let PrinterName(ByR ef theValue As String)
callStackPush mModuleName, "PrinterNam e"
On Error GoTo catchError
' PURPOSE: - To allow the using routine to set the class' Printer object
' ACCEPTS: String specifying UNC of printer. e.g. \\NTPRT41\INVHP 5SI
mCurPrinterName = theValue
Xit:
callStackPop
On Error Resume Next
Exit Property
catchError:
errorLogWrite ""
Resume Xit
End Property
Public Sub PrintReport()
6000 callStackPush mModuleName, "PrintRepor t"
6001 On Error GoTo catchError
' PURPOSE: - To allow the using routine to print the report
' - To validate all propreties before attempting to print
' SETS: - mCurErrorCount (via 'errorListAdd')
' - mCurErrorList (via 'errorListAdd')
'
' NOTES: 1) We validate parameters in three places, using mCurErrorCount to
' check after each validation:
' - In this routine
' - In validatePrinter PropsAndCapabil ities()
' - In pdfRegistrySet( )
' 2) There are no "Warning" errors. Every error is fatal.
' We do not print unless there are zero errors.
' 3) We keep checking mCurErrorCount because once certain errors
occur,
' we do not want to keep checking. e.g. Not having any printer
installed
' on the PC would pretty much defeat the rest of the checking.
' 4) BEWARE of the .ECHO situation.
' You will need to rem out the DoCmd.Echo False when debugging.
We use
' it when opening the report in 'Design' mode prior to modifying
it's
' print characteristics . .Echo False is not essential to run,
but
' True causes unsightly screen flickering.
'
6002 Dim myReport As Report
Dim myPrinter As mPrinterStruct
Dim myDevModeStruct As mPrtDevModeStru ct
Dim myByteArray() As Byte
Dim myGotPdf As Boolean
Dim myPdfFileName As String
Dim myPdfRegistryIn fo As String
Const noSuchReport = 2103
6010 If Len(mCurErrorLo gPath) > 0 Then 'This should never happen because we
default the path to application's directory
6011 If validateErrorFi lePath(mCurErro rLogPath) = False Then
6012 errorListAdd ".ErrorLogP ath: Unable to create the error log file
using path specified. Could one or more of the path's directories be missing?
Path specified = '" & mCurErrorLogPat h & "'."
6013 End If
6019 End If
6020 If Len(mCurPrinter Name) > 0 Then
6021 myPrinter = printerGet(mCur PrinterName)
6022 If Len(myPrinter.D eviceName) & "" = 0 Then
6023 errorListAdd ".PrinterNa me: Printer '" & mCurPrinterName & "' is not
installed on this PC.'"
6024 Else
6025 validatePrinter PropsAndCapabil ities myPrinter
6026 End If
6029 Else 'we probably shouldn't get this far
with no printer name, but might as well CYA...
6030 errorListAdd ".PrinterNa me: Blank printer name specified. If you
specify a printer name, it must be the name of a printer installed on this PC."
6039 End If
6040 If mCurErrorCount = 0 Then
6041 If Len(mCurReportN ame) = 0 Then
6042 errorListAdd ".ReportNam e: PROGRAM ERROR. No report name found."
6043 errorLogWrite "No report name found. We should not have gotten this
far with this condition present."
6044 Else
6045 On Error Resume Next
6046 With DoCmd
6047 .Close acReport, mCurReportName, acSaveNo
6048 .Echo False
6049 .OpenReport mCurReportName, acViewDesign
6050 End With
6200 Select Case Err
Case 0
6202 Set myReport = Reports(mCurRep ortName)
6203 If Len(mCurFilter & "") > 0 Then
6204 With myReport
6205 .Filter = mCurFilter
6206 .FilterOn = True
6207 End With
6208 End If
6209 Case noSuchReport
6210 errorListAdd ".ReportNam e: There is no such report as '" &
mCurReportName & " in this MS Access DB'."
6211 Case Else
6212 errorLogWrite ""
6213 End Select
6214 End If
6219 End If
6230 Select Case mCurView
Case acViewNormal, acViewPreview
'(a-ok, do nothing)
6232 Case Else
6233 errorListAdd ".View: Value passed = " & Format$(mCurVie w & "", "#") &
". Values allowed are: " & Format$(acViewN ormal, "#") & " = Normal, " &
Format$(acViewP review, "#") & " = Preview"
6239 End Select
' -----------------------------------
' Get the specified printer's PrtDevMode,
' modify it in accordance with properties specified by caller,
' and then copy it over the report's PrtDevMode
6410 If mCurErrorCount = 0 Then
6411 myDevModeStruct = printerDevModeG et(mCurPrinterN ame)
6412 With myDevModeStruct
6413 .intCollate = mCurDevMode.int Collate
6414 .intColor = mCurDevMode.int Color
6415 .intCopies = mCurDevMode.int Copies
6416 .intDuplex = mCurDevMode.int Duplex
6417 .intOrientation = mCurDevMode.int Orientation
6418 .intPaperLength = mCurDevMode.int PaperLength
6419 .intPaperSize = mCurDevMode.int PaperSize
6430 .intPaperWidth = mCurDevMode.int PaperWidth
6431 .intPrintQualit y = mCurDevMode.int PrintQuality
6432 .intScale = mCurDevMode.int Scale
6433 .intTTOption = mCurDevMode.int TTOption
6434 .intYResolution = mCurDevMode.int YResolution
6435 .lngFields = mCurDevMode.lng Fields
6436 End With
6437 myByteArray = devModeToBytes( myDevModeStruct )
6438 myReport.PrtDev Mode = myByteArray
6499 End If
' -----------------------------------
' Create a PrtDevNames struct that looks the same
' as the printer's and then overlay the report's
' with it
6600 If mCurErrorCount = 0 Then
6601 myByteArray = devNamesInfoBui ldForPrinter(my Printer)
6602 myReport.PrtDev Names = myByteArray
6609 End If
' -----------------------------------
' If we are sending to .PDF, generate file name and set registry
6800 If mCurErrorCount = 0 Then
6801 If Left(myPrinter. DeviceName, Len(mCurPrinter Name)) = mPdfPrinterName
Then
6802 myGotPdf = True
6803 If Not pdfWriterInstal led() Then
6804 errorListAdd "PDF Writer Not Installed: 'Acrobat PDF Writer' print
driver not found on this PC. Just the reader or a LAN connection to another
PC's writer is not enough. This PC must have a full Acrobat install including
PDF Writer."
6805 Else
6806 If Len(mCurPdfDir) & "" = 0 Then
6807 errorListAdd ".PdfDir: When printing to PDF Writer, you must
specify an existing directory into which the .PDF files will be written. e.g.
..PdfDir='C:\TE MP'."
6808 Else
6809 If dirExist(mCurPd fDir) = False Then
6820 errorListAdd ".PdfDir: Directory '" & mCurPdfDir & "' not
found. Create it or specify a different directory. Be sure to specify ONLY a
directory, NOT including a file name. File name(s) will be created from
report's object name or .Caption."
6821 Else
6822 myPdfFileName = pdfFileNameCrea te(mCurGetPdfFi leNameFrom,
mCurReportFileN amePrefix, mCurReportFileN ameSuffix, myReport)
6823 If mCurErrorCount = 0 Then
6824 If mCurShowPdfRegi stryInfo = True Then
6825 myPdfRegistryIn fo = String(40, "-") & vbCrLf & "Before
Setting Registry:" & vbCrLf & Space(15) & pdfRegistryGet( )
6826 End If
6827 If pdfRegistrySet( myPdfFileName, mCurPdfDir) Then
6828 If mCurShowPdfRegi stryInfo = True Then
6829 myPdfRegistryIn fo = myPdfRegistryIn fo & vbCrLf &
vbCrLf & String(40, "-") & vbCrLf & "After Setting Registry, But Before
Printing:" & vbCrLf & Space(15) & pdfRegistryGet( )
6840 End If
6841 Else
6842 errorListAdd "Registry Permission Problem? Unable to
set registry entries for Adobe Acrobat PDF"
6843 End If
6844 End If
6845 End If
6846 End If
6847 End If
6848 End If
6899 End If
' -----------------------------------
' Print the report
6900 If mCurErrorCount = 0 Then
6901 If mCurView = acViewPreview Then 'Abandon everything
we've done to the report so far, and just open it fresh in preview mode
6902 With DoCmd
6903 .Close acReport, mCurReportName, acSaveNo
6904 .Echo True
6905 .SetWarnings True
6906 .OpenReport mCurReportName, acPreview, , mCurFilter
6907 End With
6908 Else
6909 With DoCmd
6910 .OpenReport mCurReportName, mCurView, , mCurFilter 'Filter was
set back when we opened it in Design mode
6911 .Echo True
6912 .Close acReport, mCurReportName, acSaveNo
6913 .SetWarnings True
6914 End With
6915 If myGotPdf = True Then
6916 If mCurShowPdfRegi stryInfo = True Then
6917 myPdfRegistryIn fo = myPdfRegistryIn fo & vbCrLf & String(40,
"-") & vbCrLf & "After Printing:" & Space(5) & pdfRegistryGet( )
6918 MsgBox myPdfRegistryIn fo, vbInformation, "PDF-Related Registry
Settings"
6919 End If
6920 End If
6921 End If
6999 End If
Xit:
callStackPop
On Error Resume Next
With DoCmd
If mCurView <> acViewPreview Then
.Close acReport, mCurReportName, acSaveNo
End If
.Echo True
.SetWarnings True
End With
Set myReport = Nothing
Exit Sub
catchError:
With DoCmd
.Echo True
.SetWarnings True
End With
errorLogWrite ""
Resume Xit
End Sub
Public Property Let Collate(theValu e As rpCollate)
callStackPush mModuleName, "Collate"
On Error GoTo catchError
mCurDevMode.int Collate = theValue
mCurDevMode.lng Fields = mCurDevMode.lng Fields Or rp_Collate
Xit:
callStackPop
On Error Resume Next
Exit Property
catchError:
errorLogWrite ""
Resume Xit
End Property
Public Property Let Color(theValue As rpColor)
callStackPush mModuleName, "Color"
On Error GoTo catchError
mCurDevMode.int Color = theValue
mCurDevMode.lng Fields = mCurDevMode.lng Fields Or rp_Color
Xit:
callStackPop
On Error Resume Next
Exit Property
catchError:
errorLogWrite ""
Resume Xit
End Property
Public Property Let Copies(theValue As Integer)
callStackPush mModuleName, "Copies"
On Error GoTo catchError
mCurDevMode.int Copies = theValue
mCurDevMode.lng Fields = mCurDevMode.lng Fields Or rp_Copies
Xit:
callStackPop
On Error Resume Next
Exit Property
catchError:
errorLogWrite ""
Resume Xit
End Property
Public Property Let DefaultSource(t heValue As rpDefaultSource )
callStackPush mModuleName, "DefaultSou rce"
On Error GoTo catchError
mCurDevMode.int DefaultSource = theValue
mCurDevMode.lng Fields = mCurDevMode.lng Fields Or rp_DefaultSourc e
Xit:
callStackPop
On Error Resume Next
Exit Property
catchError:
errorLogWrite ""
Resume Xit
End Property
Public Property Let Duplex(theValue As rpDuplex)
callStackPush mModuleName, "Duplex"
On Error GoTo catchError
mCurDevMode.int Duplex = theValue
mCurDevMode.lng Fields = mCurDevMode.lng Fields Or rp_Duplex
Xit:
callStackPop
On Error Resume Next
Exit Property
catchError:
errorLogWrite ""
Resume Xit
End Property
Public Property Let ErrorLogPath(By Val theValue As String)
callStackPush mModuleName, "ErrorLogPa th"
On Error GoTo catchError
mCurErrorLogPat h = theValue
Xit:
callStackPop
On Error Resume Next
Exit Property
catchError:
errorLogWrite ""
Resume Xit
End Property
Public Property Let Filter(theValue As String)
callStackPush mModuleName, "Filter"
On Error GoTo catchError
mCurFilter = theValue
Xit:
callStackPop
On Error Resume Next
Exit Property
catchError:
errorLogWrite ""
Resume Xit
End Property
Public Property Let LaunchAcrobat(t heValue As Boolean)
callStackPush mModuleName, "LaunchAcro bat"
On Error GoTo catchError
mCurLaunchAcrob at = theValue
Xit:
callStackPop
On Error Resume Next
Exit Property
catchError:
errorLogWrite ""
Resume Xit
End Property
Public Property Let Orientation(the Value As rpOrientation)
callStackPush mModuleName, "Orientatio n"
On Error GoTo catchError
mCurDevMode.int Orientation = theValue
mCurDevMode.lng Fields = mCurDevMode.lng Fields Or rp_Orientation
Xit:
callStackPop
On Error Resume Next
Exit Property
catchError:
errorLogWrite ""
Resume Xit
End Property
'Public Property Let PaperLength(the Value As Integer)
' mCurDevMode.int PaperLength = theValue
' mCurDevMode.lng Fields = mCurDevMode.lng Fields Or rp_PaperLength
'End Property
Public Property Let PaperSize(theVa lue As rpPaperSize)
callStackPush mModuleName, "PaperSize"
On Error GoTo catchError
mCurDevMode.int PaperSize = theValue
mCurDevMode.lng Fields = mCurDevMode.lng Fields Or rp_PaperSize
Xit:
callStackPop
On Error Resume Next
Exit Property
catchError:
errorLogWrite ""
Resume Xit
End Property
'Public Property Let PaperWidth(theV alue As Integer)
' mCurDevMode.int PaperWidth = theValue
' mCurDevMode.lng Fields = mCurDevMode.lng Fields Or rp_PaperWidth
'End Property
Public Property Let PrintQuality(th eValue As rpPrintQuality)
callStackPush mModuleName, "PrintQuali ty"
On Error GoTo catchError
mCurDevMode.int PrintQuality = theValue
mCurDevMode.lng Fields = mCurDevMode.lng Fields Or rp_PrintQuality
Xit:
callStackPop
On Error Resume Next
Exit Property
catchError:
errorLogWrite ""
Resume Xit
End Property
'Public Property Let ScaleAmount(the Value As Integer)
' mCurDevMode.int Scale = theValue
' mCurDevMode.lng Fields = mCurDevMode.lng Fields Or rp_Scale
'End Property
Public Property Let ShowPdfRegistry Info(theValue As Boolean)
callStackPush mModuleName, "ShowPdfRegistr yInfo"
On Error GoTo catchError
mCurShowPdfRegi stryInfo = theValue
Xit:
callStackPop
On Error Resume Next
Exit Property
catchError:
errorLogWrite ""
Resume Xit
End Property
'Public Property Let TrueTypeOption( theValue As rpTrueType)
' callStackPush mModuleName, "TrueTypeOption "
' On Error GoTo catchError
'
' mCurDevMode.int TTOption = theValue
' mCurDevMode.lng Fields = mCurDevMode.lng Fields Or rp_T_Option
'
'Xit:
' callStackPop
' On Error Resume Next
' Exit Property
'
'catchError:
' errorLogWrite ""
' Resume Xit
'End Property
Public Property Let View(theValue As rpView)
callStackPush mModuleName, "View"
On Error GoTo catchError
mCurView = theValue
Xit:
callStackPop
On Error Resume Next
Exit Property
catchError:
errorLogWrite ""
Resume Xit
End Property
Public Property Let YResolution(the Value As Integer)
callStackPush mModuleName, "YResolutio n"
On Error GoTo catchError
mCurDevMode.int YResolution = theValue
mCurDevMode.lng Fields = mCurDevMode.lng Fields Or rp_Y_Resolution
Xit:
callStackPop
On Error Resume Next
Exit Property
catchError:
errorLogWrite ""
Resume Xit
End Property
Public Function legalFileName(B yVal theName As String) As String
callStackPush mModuleName, "legalFileN ame"
On Error GoTo catchError
' PURPOSE: To convert a string into something that can function as
' part of a DOS file name
' ACCEPTS: The string to be converted
' RETURNS: A string with any illegal characters replaced with underscores
'
' NOTES: 1) We originally decided which chars to replace by trying to
' rename a file to something containing "?"(which we knew was
' illegal) and then noting the other illegal chars described
' in the error message.
Dim badBoyz() As Variant
Dim L As Long
Dim i As Integer
Dim isDone As Boolean
Dim myName As String
Dim arraySize As Integer
Const underScore = "_"
myName = theName
badBoyz = Array("/", "\", ":", "*", "?", Chr$(34), "<", ">", "|")
arraySize = UBound(badBoyz)
For i = 0 To arraySize
isDone = False
Do Until isDone = True
L = InStr(1, myName, badBoyz(i))
If L = 0 Then
isDone = True
Else
Mid$(myName, L, 1) = underScore
End If
Loop
Next i
legalFileName = myName
Xit:
callStackPop
On Error Resume Next
Exit Function
catchError:
errorLogWrite ""
Resume Xit
End Function
Private Function pdfWriterInstal led() As Boolean
callStackPush mModuleName, "pdfWriterInsta lled"
On Error GoTo catchError
' PURPOSE: To determine whether-or-not the Adobe Acrobat PDFWriter
' is installed on an NT 4.0 or later machine.
'
' RETURNS: True if installed, False if not
Dim hPrinter As Long
If OpenPrinter(mPd fPrinterName, hPrinter, 0) Then
ClosePrinter (hPrinter)
pdfWriterInstal led = True
End If
Xit:
callStackPop
On Error Resume Next
Exit Function
catchError:
errorLogWrite ""
Resume Xit
End Function
Public Function dirExist(ByVal theDirPath As Variant) As String
callStackPush mModuleName, "dirExist"
On Error GoTo catchError
' PURPOSE: To determine whether-or-not a directory exists
' ACCEPTS: A path to the directory in question
' RETURNS: Empty string if directory exists, else a message telling why not
found.
Dim skipLine As String
dirExist = (Dir$(theDirPat h, vbDirectory) <> "")
Xit:
callStackPop
On Error Resume Next
Exit Function
catchError:
Select Case Err
Case 71
MsgBox "That path refers to a floppy disk. Please insert the disk.", 49,
"Insert Disk"
Case 76
'(We expect 76 if no file found)
Case 68
errorListAdd "Bad Directory. The system has reported that drive " &
UCase$(Left$(th eDirPath, 2)) & " is unavailable."
Case Else
errorLogWrite "Unexpected case"
End Select
Resume Xit
End Function
Private Sub errorListAdd(By Val theMessage As String)
On Error GoTo catchError
' PURPOSE: To add an error to mCurErrorList and increment the error count
' ACCEPTS: The error message to add
'
' NOTES: 1) Limited error trapping because we are already in an error
' situation and want to avoid any chance of a loop
mCurErrorCount = mCurErrorCount + 1
If Len(mCurErrorLi st) = 0 Then
mCurErrorList = "clsReportPrint er, version " & mVersionNumber & vbCrLf &
vbCrLf & mErrorListMessa gePrefix & theMessage
Else
mCurErrorList = mCurErrorList & vbCrLf & mErrorListMessa gePrefix &
theMessage
End If
Xit:
On Error Resume Next
Exit Sub
catchError:
MsgBox "clsReportPrint er: runtime error in errorListAdd()"
Resume Xit
End Sub
Private Function printerDevModeG et(ByVal thePrinterName As String) As
mPrtDevModeStru ct
callStackPush mModuleName, "printerDevMode Get"
On Error GoTo catchError
' PURPOSE: To retrieve the PrtDevMode structure for the named printer
' ACCEPTS: Printer name (e.g. \\NTPRT41\INVHP 5SI)
' RETURNS: Printer's DevMode structure
Dim myDevModeStruct As mPrtDevModeStru ct
Dim myDevModeBytes( ) As Byte
Dim myDevModeLen As Long
Dim hPrinter As Long
Dim myDummyByte As Byte
Const myBufLen = 2
On Error GoTo catchError
If OpenPrinter(the PrinterName, hPrinter, 0) Then
If hPrinter > 0 Then
myDevModeLen = DocumentPropert ies(0, hPrinter, thePrinterName,
myDummyByte, myDummyByte, 0)
If myDevModeLen > 0 Then
ReDim myDevModeBytes( 1 To myDevModeLen)
If DocumentPropert ies(0, hPrinter, thePrinterName, myDevModeBytes( 1),
myDevModeBytes( 1), myBufLen) > 0 Then
myDevModeStruct = bytesToDevMode( myDevModeBytes)
printerDevModeG et = myDevModeStruct
End If
End If
End If
Call ClosePrinter(hP rinter)
End If
Xit:
callStackPop
On Error Resume Next
Exit Function
catchError:
errorLogWrite ""
Resume Xit
End Function
Private Function bytesToDevMode( ByRef theByteArray() As Byte) As
mPrtDevModeStru ct
callStackPush mModuleName, "bytesToDevMode "
On Error GoTo catchError
' PURPOSE: To convert an array of Byte into a PrtDevMode structure
' ACCEPTS: An array of Byte
' RETURNS: A DevMode structure containing same info as passed byte array
Dim myDevModeStruct As mPrtDevModeStru ct
Dim myDevModeString As mDevModeStringS truct
myDevModeString .strDevMode = theByteArray
LSet myDevModeStruct = myDevModeString
bytesToDevMode = myDevModeStruct
Xit:
callStackPop
On Error Resume Next
Exit Function
catchError:
errorLogWrite ""
Resume Xit
End Function
Private Function devModeToBytes( ByRef theDevMode As mPrtDevModeStru ct) As Byte()
callStackPush mModuleName, "devModeToBytes "
On Error GoTo catchError
' PURPOSE: To comvert a PrtDevMode structure into an array of Byte
' ACCEPTS: Pointer to the struct in question
' RETURNS: An array of Byte containing same info as in passed structure
'
' NOTES: 1) Apparently there can be some extra characters on the end of
' the intermediate string we create, hence the need to trim it
' via LeftB()
Dim myByteArray() As Byte
Dim myDevModeString As mDevModeStringS truct
LSet myDevModeString = theDevMode
myByteArray = LeftB(myDevMode String.strDevMo de, theDevMode.intS ize +
theDevMode.intD riverExtra)
devModeToBytes = myByteArray
Xit:
callStackPop
On Error Resume Next
Exit Function
catchError:
errorLogWrite ""
Resume Xit
End Function
Private Function uniToAnsi(strUn i As String) As Variant
callStackPush mModuleName, "uniToAnsi"
On Error GoTo catchError
' PURPOSE: To convert a Unicode string to ANSI.
' ACCEPTS: UniCode string
' RETURNS: ANSI string
'
' NOTES: 1)We must return a Variant, or VBA will convert
' it back to Unicode for you - just as a favor...
uniToAnsi = StrConv(strUni, vbFromUnicode)
Xit:
callStackPop
On Error Resume Next
Exit Function
catchError:
errorLogWrite ""
Resume Xit
End Function
Private Function devNamesInfoBui ldForPrinter(By Ref thePrinter As mPrinterStruct)
As Byte()
4000 callStackPush mModuleName, "devNamesInfoBu ildForPrinter"
4001 On Error GoTo catchError
' PURPOSE: Create a PrtDevNames structure for a given printer
' ACCEPTS: Structure containing information for the printer in question
' RETURNS: Byte array containing info needed to create a PrtDevNames
structure
4002 Dim myDNOI As mDevNamesOffset InfoStruct
Dim myOffsetString As mDevNamesOffset StringStruct
Dim myDefaultPrinte r As mPrinterStruct
Dim myBytes As Variant
' 4003 DoCmd.OpenRepor t ("Bogus") 'For use when debugging the error
handling routines
' ---------------------------------------------
' Check for maximum length for the device name
' (leaving room for the null terminator)
4011 If Len(thePrinter. DeviceName) > adhcMaxDevice - 1 Then
4012 thePrinter.Devi ceName = Left$(thePrinte r.DeviceName, adhcMaxDevice - 1)
4019 End If
' ---------------------------------------------
' The first offset is always offset 8
4020 With myDNOI
4021 .DriverOffset = adhcDevNamesFix ed
4022 .DeviceOffset = .DriverOffset + Len(thePrinter. DriverName) + 1
4023 .OutputOffset = .DeviceOffset + Len(thePrinter. DeviceName) + 1
4024 .IsDefaultPrint er = thePrinter.IsDe faultPrinter
4029 End With
' ---------------------------------------------
' If all the information in thePrinter matches the current
' default printer, then set Default to be 1.
4030 myDefaultPrinte r = printerDefaultG et
4031 With myDefaultPrinte r
4032 If (.DeviceName = thePrinter.Devi ceName) And (.DriverName =
thePrinter.Driv erName) And .Port = thePrinter.Port Then
4033 myDNOI.IsDefaul tPrinter = 1
4034 End If
4039 End With
' ---------------------------------------------
4041 LSet myOffsetString = myDNOI
4042 myBytes = myOffsetString. strDevInfo
4049 myBytes = myBytes & uniToAnsi(thePr inter.DriverNam e) & ChrB$(0) &
uniToAnsi(thePr inter.DeviceNam e) & ChrB$(0) & uniToAnsi(thePr inter.Port) &
ChrB$(0)
4999 devNamesInfoBui ldForPrinter = myBytes
Xit:
callStackPop
On Error Resume Next
Exit Function
catchError:
errorLogWrite ""
Resume Xit
End Function
Private Function regKeyValueSet( ByVal theRootKey As Long, ByVal theKeyName As
String, ByVal theValueName As String, ByVal theValueData As Variant, ByVal
theValueType As Long, ByRef theErrorMessage As String) As Boolean
callStackPush mModuleName, "regKeyValueSet "
On Error GoTo catchError
' ACCEPTS: - Root key value
' - Name of the key to open
' - Name of the value to open, vbNullString will open the default
value
' - Data to assign to the value
' - Data type of the value
' RETURNS: TRUE or FALSE depending on success
' SETS: - Error message in event of problem
Dim x As Long
Dim myKeyHandle As Long
x = RegCreateKeyEx( theRootKey, theKeyName, 0&, vbNullString,
mRegOptionNonVo latile, mRregKeyAllAcce ss, 0&, myKeyHandle, 0&)
If x <> 0 Then
theErrorMessage = "[ERROR: " & Str(x) & " returned by RegCreateKeyEx. "
Else
Select Case theValueType
Case mRegSz
x = RegSetValueExSt ring(myKeyHandl e, theValueName, 0&, theValueType,
theValueData, Len(theValueDat a))
If x <> 0 Then
theErrorMessage = "[ERROR: " & Str(x) & " returned by
RegSetValueExSt ring."
Else
regKeyValueSet = True
End If
Case mRegDWord
x = RegSetValueExLo ng(myKeyHandle, theValueName, 0&, theValueType,
theValueData, mRegDWord)
If x <> 0 Then
theErrorMessage = "[ERROR: " & Str(x) & " returned by
RegSetValueExLo ng."
Else
regKeyValueSet = True
End If
End Select
End If
Xit:
callStackPop
On Error Resume Next
RegCloseKey (myKeyHandle)
Exit Function
catchError:
errorLogWrite ""
Resume Xit
End Function
Private Function pdfRegistrySet( ByVal thePdfFileNameR aw As Variant, ByVal
theOutputDir As Variant) As Boolean
3000 callStackPush mModuleName, "pdfRegistrySet "
3001 On Error GoTo catchError
' PURPOSE: To set the registry values needed by PDFWriter to create a .PDF
file
' without issuing a common file dialog to the user.
' ACCEPTS: - Caption or MS Access object name of the report it is going to
create
' a .PDF file for
' - A path to the directory where the .PDF file will be wirtten.
' (Does *not* include file name. We develop that from the caption
or object name.)
' USES: mCurDevMode to get:
' - The paper size it should use (expressed as Enum rpPaperSize
' constants and then translated by this routine into Acrobat
constants)
' - The orientation on that paper )expressed as Enum rpOrientation
constants
' and translated....)
' - A pointer to the report in question, so we can set it's
..SpecificPrint er
' before turning PDFWriter loose on it.
'
' RETURNS: True or False depending on success
' SETS: Acrobat registry entries for
' - Paper size
' - Paper orientation
' - Path where .PDF will be written
'
' NOTES: 1) Windows PrdDevName constants for paper size and orientation
differ from
' Adobe's, so we have to translate them.
' 2) The calling routine is responsible for supplying a valid
existing
' directory path *WITHOUT* file name.
' 3) If a paper size that Adobe can't handle is passed, we just set
paper size
' to Tabloid since that's the biggest.
' 4) Ditto orientation...w e force LandScape if something besides
' portrait or landscape comes through
3002 Dim myOutputDir As String
Dim myPdfFileName As String
Dim myPdfFilePath As String
Dim myAcrobatPaperS ize As String
Dim myAcrobatOrient ation As String
Dim myValueName As String
Dim myValueData As String
Dim myErrorMessage As String
Const myDelim = ", "
3010 myValueName = "bExecViewe r"
3011 If (mCurLaunchAcro bat <> 0) And (mCurLaunchAcro bat <> -1) Then
3012 errorListAdd ".LaunchAcrobat : Values allowed: True (i.e. -1) or
False (i.e. 0). Value passed = " & Format$(mCurLau nchAcrobat & "", "0#") & ".
"
3013 Else
3014 If mCurLaunchAcrob at = True Then
3015 myValueData = "1"
3016 Else
3017 myValueData = "0" 'Do not launch Acrobat when we
create the .PDF file
3019 End If
3020 regKeyValueSet mRegHKeyCurrent User, mPdfWriterKeyNa me, myValueName,
myValueData, mRegSz, myErrorMessage
3029 End If
3160 myPdfFileName = legalFileName(t hePdfFileNameRa w)
3170 myPdfFilePath = theOutputDir & "\" & myPdfFileName & ".pdf"
3200 Select Case mCurDevMode.int Orientation
Case rporient_Portra it
3211 myAcrobatOrient ation = "1"
3220 Case rporient_landsc ape
3221 myAcrobatOrient ation = "2"
3230 Case Else
3231 errorLogWrite "Unexpected case = " & Str(mCurDevMode .intOrientation )
& ". Invalid orientation should have been caught in
validatePrinter PropsAndCapabil ities()."
3299 End Select
3300 Select Case mCurDevMode.int PaperSize
Case rpPaper_Letter
3319 myAcrobatPaperS ize = "0"
3320 Case rpPaper_Legal
3329 myAcrobatPaperS ize = "1"
3330 Case rpPaper_Tabloid
3339 myAcrobatPaperS ize = "2"
3340 Case rpPaper_A4, rpPaper_A4_Smal l
3349 myAcrobatPaperS ize = "3"
3350 Case rpPAPER_A3
3359 myAcrobatPaperS ize = "4"
3360 Case rpPaper_Executi ve
3369 myAcrobatPaperS ize = "5"
3370 Case rpPaper_B4
3379 myAcrobatPaperS ize = "6"
3380 Case rpPaper_B5
3389 myAcrobatPaperS ize = "7"
3490 Case Else
3499 errorListAdd ".PaperSize : Values allowed with PDF Writer are: " _
& Format$(rpPaper _Letter, "0#") & " = Letter" _
& myDelim & Format$(rpPaper _Legal, "0#") & " = Legal" _
& myDelim & Format$(rpPaper _Tabloid, "0#") & " =
Tabloid" _
& myDelim & Format$(rpPaper _Executive, "0#") & " =
Executive" _
& myDelim & Format$(rpPAPER _A3, "0#") & " = A3" _
& myDelim & Format$(rpPaper _A4, "0#") & " = A4" _
& myDelim & Format$(rpPaper _A4_Small, "0#") & " = A4
Small" _
& myDelim & Format$(rpPaper _B4, "0#") & " = B4" _
& myDelim & Format$(rpPaper _B5, "0#") & " = B5" _
& myDelim & " Value specified = " &
Format$(mCurDev Mode.intPaperSi ze & "", "0#") & "."
3500 End Select
2599 pdfRegistrySet = True 'We don't want to
return False if the only problem is validation
3700 If (Len(myAcrobatO rientation) > 0) And (Len(myAcrobatP aperSize) > 0) Then
3701 pdfRegistrySet = False
3710 myValueName = "PDFFileNam e"
3711 myValueData = myPdfFilePath
3712 regKeyValueSet mRegHKeyCurrent User, mPdfWriterKeyNa me, myValueName,
myValueData, mRegSz, myErrorMessage
3720 myValueName = "paper"
3721 myValueData = myAcrobatPaperS ize
3722 regKeyValueSet mRegHKeyCurrent User, mPdfWriterKeyNa me, myValueName,
myValueData, mRegSz, myErrorMessage
3730 myValueName = "orient"
3731 myValueData = myAcrobatOrient ation
3732 regKeyValueSet mRegHKeyCurrent User, mPdfWriterKeyNa me, myValueName,
myValueData, mRegSz, myErrorMessage
3740 myValueName = "bDocInfo"
3741 myValueData = "0"
3742 regKeyValueSet mRegHKeyCurrent User, mPdfWriterKeyNa me, myValueName,
myValueData, mRegSz, myErrorMessage
3745 myValueName = "bEmbedAllFonts "
3746 myValueData = "0"
3747 regKeyValueSet mRegHKeyCurrent User, mPdfWriterKeyNa me, myValueName,
myValueData, mRegSz, myErrorMessage
3750 pdfRegistrySet = True
3999 End If
Xit:
callStackPop
On Error Resume Next
Exit Function
catchError:
errorLogWrite "Raw PDF FileName = '" & thePdfFileNameR aw & ", Papersize=" &
Str(mCurDevMode .intPaperSize) & ", Orientation=" &
Str(mCurDevMode .intOrientation ) & ", Output Dir='" & theOutputDir & "', Path =
'" & myPdfFilePath & "',"
Resume Xit
End Function
Private Function regKeyValueGet( ByVal theRootKey As Long, ByVal theKeyName As
String, ByVal theValueName As String, ByRef theReturnValue As Variant) As
Boolean
2000 callStackPush mModuleName, "regKeyValueGet "
2001 On Error GoTo catchError
' ACCEPTS: - The root key value, which must be one of the following
constants:
' + gRegHKeyClasses Root
' + gRegHKeyCurrent User
' + gRegHKeyLocalMa chine
' + gRegHKeyUsers
' - Name of the key to open
' - Name of the value to open. "vbNullStri ng" will open the
default value.
' RETURNS: TRUE or FALSE depending on success
' SETS: Variant containing the registry value's data or an error message
'
' EXAMPLE: x = regKeyValueGet( gRegHKeyLocalMa chine,
"Software\ODBC\ ODBC.INI\AGENCY ", "ServerName ", myValueData)
2010 Dim myKeyHandle As Long
Dim myStringValue As String
Dim myLongValue As Long
Dim myValueType As Long
Dim myDataLength As Long
Dim x As Long
2020 theReturnValue = Empty
2030 x = RegOpenKeyEx(th eRootKey, theKeyName, 0&, mRegKeyQueryVal ue,
myKeyHandle)
2040 If x <> 0 Then
2050 theReturnValue = "[ERROR " & Str(x) & " returned by RegOpenKeyEx]"
2060 Else
2070 x = RegQueryValueEx A(myKeyHandle, theValueName, 0&, myValueType, 0&,
myDataLength)
2080 If x <> 0 Then
2090 If x = 2 Then
2100 theReturnValue = "[ERROR " & Str(x) & ": key not
found....Return ed by RegQueryValueEx A]"
2110 Else
2120 theReturnValue = "[ERROR " & Str(x) & " returned by
RegQueryValueEx A]"
2130 End If
2140 Else
2141 If myDataLength > 0 Then
2150 Select Case myValueType
Case mRegSz: ' String
2170 myStringValue = String(myDataLe ngth - 1, 0)
2180 x = RegQueryValueEx String(myKeyHan dle, theValueName, 0&,
myValueType, myStringValue, myDataLength)
2190 If x <> 0 Then
2200 theReturnValue = "[ERROR " & Str(x) & " returned by
RegQueryValueEx String]"
2210 Else
2220 theReturnValue = Left$(myStringV alue, myDataLength)
2230 regKeyValueGet = True
2240 End If
2250 Case mRegDWord: ' Long
x = RegQueryValueEx Long(myKeyHandl e, theValueName, 0&,
myValueType, myLongValue, myDataLength)
2260 If x <> 0 Then
2270 regKeyValueGet = "[ERROR " & Str(x) & " returned by
RegQueryValueEx Long]"
2280 Else
2290 theReturnValue = myLongValue
2300 regKeyValueGet = True
2310 End If
2320 Case Else ' No other
data types supported
2321 errorLogWrite "Unexpected case: " & Str(myValueType ) & ".
Only String and Long supported"
2330 End Select
2335 End If
2340 End If
2999 End If
Xit:
callStackPop
On Error Resume Next
Exit Function
catchError:
errorLogWrite ""
Resume Xit
End Function
Private Function pdfRegistryGet( ) As String
callStackPush mModuleName, "pdfRegistryGet "
On Error GoTo catchError
' PURPOSE: To assist debugging by retrieving all the PDF-specific registry
entires.
' RETURNS: Registry Entries
Dim myString As String
Dim myValue1 As String
Dim myValue2 As String
Dim myValue3 As String
Const myValueName1 = "bDocInfo"
Const myValueName2 = "PDFFileNam e"
Const myValueName3 = "TPDFFileNa me"
If regKeyValueGet( mRegHKeyCurrent User, mPdfWriterKeyNa me, myValueName1,
myValue1) = False Then
myValue1 = "(key not found in registry)"
End If
If regKeyValueGet( mRegHKeyCurrent User, mPdfWriterKeyNa me, myValueName2,
myValue2) = False Then
myValue2 = "(key not found in registry)"
End If
If regKeyValueGet( mRegHKeyCurrent User, mPdfWriterKeyNa me, myValueName3,
myValue3) = False Then
myValue3 = "(key not found in registry)"
End If
myString = myValueName1 & " = '" & myValue1 & "'" & vbCrLf & myValueName2 & "
= '" & myValue2 & "'" & vbCrLf & myValueName3 & " = '" & myValue3 & "'"
pdfRegistryGet = myString
Xit:
callStackPop
On Error Resume Next
Exit Function
catchError:
errorLogWrite ""
Resume Xit
End Function
Private Sub printerArrayLoa d()
callStackPush mModuleName, "printerArrayLo ad"
On Error GoTo catchError
' PURPOSE: To load the class' array with all printers currently installed on
' this PC by referring to (the [devices] section in WIN.INI???)
' RETURNS: A collection as above
'
' NOTES: 1) I'm not positive that we're not going to the registry
' 1) When we loop through the list of printers, we assume that
' no two printers have the same name.
' 2 A given INI/Registry entry for a printer will look like this:
' "HP DeskJet 890C Series=winspool ,LPT1:"
' so we split it twice: first on "=" and then we split the
' result of the "=" split on ",".
Dim myIniSectionArr ay() As String
Dim myIniDetailsArr ay1() As String
Dim myIniDetailsArr ay2() As String
Dim i As Integer
Dim k As Integer
Dim myParmCount As Integer
Dim myIniSection As String
myIniSection = iniSectionGet(" Devices")
If Len(myIniSectio n) = 0 Then
myParmCount = 0
Else
myIniSectionArr ay = Split(myIniSect ion, vbNullChar)
ReDim aDevList(LBound (myIniSectionAr ray) To UBound(myIniSec tionArray))
For i = LBound(myIniSec tionArray) To UBound(myIniSec tionArray)
If Len(myIniSectio nArray(i)) > 0 Then
myIniDetailsArr ay1 = Split(myIniSect ionArray(i), "=")
myIniDetailsArr ay2 = Split(myIniDeta ilsArray1(1), ",")
k = k + 1
ReDim Preserve mCurPrinters(k)
With mCurPrinters(k)
.DeviceName = myIniDetailsArr ay1(0)
.DriverName = myIniDetailsArr ay2(0)
.Port = myIniDetailsArr ay2(1)
End With
End If
Next i
End If
Xit:
callStackPop
On Error Resume Next
Exit Sub
catchError:
errorLogWrite ""
Resume Xit
End Sub
Private Function printerGet(ByVa l thePrinterName As String) As mPrinterStruct
7000 callStackPush mModuleName, "printerGet "
7001 On Error GoTo catchError
' PURPOSE: To allow using routines to retrieve a named printer
' from the class' array
' ACCEPTS: UNC of the printer. e.g. \\NTPRT07\INVHP 5SI
' RETURNS: Struct containing printer info: populated or empty, depending...
'
' NOTES: 1) There is no guarantee that the mCurPrinters has been loaded
because
' the PC may not have any printers installed. For want of a
better
' method, we detect this situation by trapping for a subscript
range error.
7002 Dim myPrinter As mPrinterStruct
Dim i As Integer
Dim gotPrinter As Boolean
Const subscriptOutOfR ange = 9
7010 For i = 0 To UBound(mCurPrin ters)
7020 With mCurPrinters(i)
7030 If .DeviceName = thePrinterName Then
7040 myPrinter.IsDef aultPrinter = .IsDefaultPrint er
7050 myPrinter.Devic eName = .DeviceName
7060 myPrinter.Drive rName = .DriverName
7070 myPrinter.Port = .Port
7080 gotPrinter = True
7090 Exit For
7100 End If
7110 End With
7120 Next i
7999 printerGet = myPrinter
Xit:
callStackPop
On Error Resume Next
Exit Function
catchError:
Select Case Err
Case subscriptOutOfR ange
'(do nothing, indicates that no printers are installed)
Case Else
errorLogWrite ""
End Select
Resume Xit
End Function
Private Function printerDefaultG et() As mPrinterStruct
callStackPush mModuleName, "printerDefault Get"
On Error GoTo catchError
' PURPOSE: Get information on the Windows default printer
' RETURNS: Structure
'
' NOTES: 1) The default printer name string has to contain
' three elements delimited by comma. If not, we
' have a trappable error
Dim myPrinter As mPrinterStruct
Dim myDetailsArray( ) As String
Dim strPrinter As String
strPrinter = printerDefaultI nfoGet()
If Len(strPrinter) > 0 Then
myDetailsArray = Split(strPrinte r, ",")
With myPrinter
.DeviceName = myDetailsArray( 0)
.DriverName = myDetailsArray( 1)
.Port = myDetailsArray( 2)
End With
End If
printerDefaultG et = myPrinter
Xit:
callStackPop
On Error Resume Next
Exit Function
catchError:
errorLogWrite ""
Resume Xit
End Function
Private Function printerDefaultI nfoGet() As String
callStackPush mModuleName, "printerDefault InfoGet"
On Error GoTo catchError
' PURPOSE: To get the current default printer's information string
' RETURNS: String containing printer's information or, if no default printer,
empty string
Dim myBuff As String
Dim myBuffLen As Integer
Const myBuffLim = 2048
Const noPrintersFound = ""
myBuff = Space(myBuffLim )
myBuffLen = GetProfileStrin g("Windows", "Device", noPrintersFound , myBuff,
myBuffLim - 1)
printerDefaultI nfoGet = Left$(myBuff, myBuffLen)
Xit:
callStackPop
On Error Resume Next
Exit Function
catchError:
errorLogWrite ""
Resume Xit
End Function
Public Property Get Help()
callStackPush mModuleName, "Help"
On Error GoTo catchError
' PURPOSE: - To act as a repository for documentation of this function's methods
and properties
' - To allow the calling routine to show same
MsgBox "This is a stub for yet-to-be-implemented 'Help' method." & vbCrLf &
vbCrLf & "The final product may document the class' methods and properties and
show some sample code by creating/opening an HTML document.", vbInformation,
"Under Construction"
Xit:
callStackPop
On Error Resume Next
Exit Property
catchError:
errorLogWrite ""
Resume Xit
End Property
Private Function iniSectionGet(B yVal theGroupRequest ed As String) As String
callStackPush mModuleName, "iniSection Get"
On Error GoTo catchError
' PURPOSE: To retrieve an entire section from Win.INI.
' ACCEPTS: The name of the group we want to get
' RETURNS: A string containing the contents of the group (exclusive of header)
'
' NOTES: 1) Used to get a list of all the printers
' 2) CAVEAT: I suspect that the API call really goes to the
' registry, since I can't find a section in my own
' machine's WIN.INI that has printers in it.
Dim myBuff As String
Dim myBuffLen As Integer
Const myBuffLim = 10000
myBuff = Space(myBuffLim )
myBuffLen = GetProfileSecti on(theGroupRequ ested, myBuff, myBuffLim - 1)
iniSectionGet = Left$(myBuff, myBuffLen)
Xit:
callStackPop
On Error Resume Next
Exit Function
catchError:
errorLogWrite ""
Resume Xit
End Function
Private Sub errorLogWrite(B yVal theSupplemental Message As String)
' PURPOSE: - To write the passed information to the .ErrorList
' - To make the error bubble up to whatever client is using this
class.
' - If .ErrorLogPath specified, to write the information there,
otherwise write
' it to a default path.
'
' ACCEPTS: Programmer-supplied supplemental description
' USES: .ErrorLogPath property defining log file directory and file name
'
' NOTES: 1) First thing we have to do is capture all of the "real" error's
properties.
' 2) "noLocalErr or" is needed because we also might raise an error
in this routine (i.e. a "local"
' error).
' 3) We also post the error to the class' mCurErrorList so it will
affect the
' result of any attempt to do a .PrintReport. We do not call
errorListAdd()
' because we don't want to invoke it's error trapping - since it
would be
' recursive as we are already in error mode
' 4) If .ErrorLogPath has been specified, we have already validated
it before coming here.
' 5) The assumption is that drive C: exists.
1000 Dim myErl As Long
Dim myNumber As Long
Dim mySource As String
Dim myDescription As String
Dim myString As String
1040 myErl = Erl
1041 myNumber = Err.Number
1042 mySource = Err.Source
1049 myDescription = Err.description
1050 On Error GoTo errorLogWrite_x it
1051 DoCmd.Echo True 'In case it was turned off
somewhere else
1060 If myErl = 0 Then
1061 mySource = mySource & ":" & mCallStack(mCal lStackPointer)
1062 Else
1063 mySource = mySource & ":" & mCallStack(mCal lStackPointer) & ": Line# " &
Str(myErl)
1069 End If
1070 mCurErrorCount = mCurErrorCount + 1
1079 myString = mErrorListMessa gePrefix & "RUN-TIME ERROR @" & mySource & " --
Error# " & Format$(myNumbe r, "0000") & ": " & myDescription & " " &
theSupplemental Message
1080 If Len(mCurErrorLi st) = 0 Then
1081 mCurErrorList = myString
1082 Else
1083 mCurErrorList = mCurErrorList & vbCrLf & myString
1089 End If
1100 Dim i As Integer
1110 Dim x As Integer
1115 Dim noLocalError As Boolean
1120 Dim ErrorLogPath As String
1240 ErrorLogPath = errorLogPathGet ()
1300 mySource = vbTab & "This error bubbled up from: " & mySource
1310 x = FreeFile
1320 Open ErrorLogPath For Append As x
1400 Print #x,
"--------------------------------------------------------------------"
1410 Print #x, Format$("When: " & Now, "mm/dd/yy hh:nn:ss") & ", Who: " &
userNameGet() & ", What: " & computerNameGet () & ", Where: " &
mCallStack(mCal lStackPointer)
1420 If myErl > 0 Then
1430 Print #x, String(13, " ") & "Line " & Format$(myErl, "000000") & " " &
Format$(myNumbe r, "0000") & ": " & myDescription
1440 Else
1450 Print #x, String(13, " ") & Format$(myNumbe r, "0000") & ": " &
myDescription
1460 End If
1470 If theSupplemental Message <> "" Then
1480 Print #x, Space$(19) & theSupplemental Message
1490 End If
1500 Print #x, ""
1600 If mCallStackPoint er > 1 Then
1610 For i = 0 To mCallStackLim
1620 If mCallStack(i) <> "" Then
1630 If i = mCallStackPoint er Then
1640 Print #x, Space$(9) & " " & Format(i, "00") & ">>" &
mCallStack(i)
1650 Else
1660 If i = 1 Then
1670 Print #x, Space$(9) & "CallOuts: " & Format(i, "00") & " "
& mCallStack(i)
1680 Else
1690 Print #x, Space$(9) & " " & Format(i, "00") & " "
& mCallStack(i)
1700 End If
1710 End If
1720 End If
1730 Next i
1740 End If
1900 Close #x
1999 noLocalError = True
errorLogWrite_x it:
If noLocalError = True Then
If myNumber = 0 Then
myNumber = 999 'In case we called errorLogWrite just for
informational purposes.
End If
' On Error Resume Next
Err.Raise myNumber, mySource & vbCrLf & vbTab & myDescription & vbCrLf &
vbTab & "This text is also logged in '" & ErrorLogPath & "'."
Else
Err.Raise Err.Number, Err.Source & ":" & "errorLogWr ite, line " & Erl & "
(error in error handler)", Err.description
End If
Exit Sub
End Sub
Private Sub callStackPop()
' PURPOSE: To remove most-recently-added procedure name from the debug stack
array
On Error Resume Next 'To prevent looping if/when stack gets
overflowed...
mCallStack(mCal lStackPointer) = ""
mCallStackPoint er = mCallStackPoint er - 1
If mCallStackPoint er < 0 Then
mCallStackPoint er = 0
End If
Exit Sub
End Sub
Private Sub callStackPush(B yVal theModuleName As String, ByVal theProcedureNam e
As String)
' PURPOSE: To add "theProcedureNa me" to the debug stack array
' NOTES: 1)If the programmer invokes this routine but neglects to invoke
"callStackP op"
' at the end of the procedure, there is a chance that the stack will
get
' overflowed. Therefore we have some error handling at the end to
track
' such situations. "overflowLogged " is a switch we use to prevent
an undue
' number of writes.
On Error GoTo callStackPush_e rr
Static overflowLogged As Boolean
mCallStackPoint er = mCallStackPoint er + 1
mCallStack(mCal lStackPointer) = theModuleName & ":" & theProcedureNam e
callStackPush_x it:
Exit Sub
callStackPush_e rr:
If overflowLogged = False Then
errorLogWrite "Call Stack Overflow: Stack = " & Str(mCallStackP ointer) & "
(Stack Limit = " & Str(mCallStackL im)
End If
overflowLogged = True
Resume callStackPush_x it
End Sub
Private Function userNameGet() As String
On Error Resume Next
' PURPOSE: To extract the LAN userID of the person currently logged on
' RETURNS: UserID or blank string
'
' NOTES: 1) NO ERROR TRAPPING. Tailored for use during errorLogWrite process.
' To avoid recursive loops, there are no calls to errorLogWrite
routines.
Dim L As Long
Dim myBuffer As String
Const buffLen = 255
myBuffer = Space(buffLen)
L = GetUserName(myB uffer, buffLen)
userNameGet = stripNulls_elw( myBuffer)
End Function
Private Function computerNameGet () As String
On Error Resume Next
' PURPOSE: To extract the name of the user's PC via Windows API
'
' NOTES: 1) NO ERROR TRAPPING. Tailored for use during errorLogWrite process.
' To avoid recursive loops, there are no calls to errorLogWrite
routines.
Dim L As Long
Dim myBuffer As String
Const buffLen = 255
myBuffer = Space(buffLen)
L = GetComputerName (myBuffer, buffLen)
computerNameGet = stripNulls_elw( myBuffer)
End Function
Private Function stripNulls_elw( ByVal theStringWithNu lls As String) As String
On Error Resume Next
' PURPOSE: To strip any nulls out of the passed string
' ACCEPTS: The string we want to strip nulls out of
' RETURNS: A copy of the passed string with nulls stripped
'
' NOTES: 1) NO ERROR TRAPPING. Tailored for use during errorLogWrite
process. To avoid recursive loops,
' there are no calls to errorLogWrite routines.
Dim myString As String
If InStr(1, theStringWithNu lls, Chr(0), vbTextCompare) Then
myString = Mid(theStringWi thNulls, 1, InStr(theString WithNulls, Chr(0)) -
1)
Else
myString = theStringWithNu lls
End If
stripNulls_elw = myString
End Function
Private Function errorLogPathGet () As String
' PURPOSE: To build the path where we write our errors to
'
' NOTES: 1) NO ERROR TRAPPING. Tailored for use during errorLogWrite process.
' To avoid recursive loops, there are no calls to errorLogWrite
routines.
Dim myAppDir As String
Const defaultErrorLog Name = "clsReportPrint er.ErrorLog.txt "
If Len(mCurErrorLo gPath) = 0 Then
myAppDir = extractDirFromF ullPath_elw(App lication.Curren tDb.Name)
errorLogPathGet = myAppDir & "\" & defaultErrorLog Name
Else
errorLogPathGet = mCurErrorLogPat h
End If
End Function
Function fileExist(ByVal theFilePath As Variant) As Integer
callStackPush mModuleName, "fileExist"
On Error GoTo catchError
' PURPOSE: To determine whether-or-not a file exists
' ACCEPTS: A full path to the file in question
' RETURNS: True or False depending...
'
' NOTES: 1) If we drop into the errro trap, not only does
' the file does not exist, but something unexpected
' has happened
fileExist = (Dir$(theFilePa th) <> "")
fileExist_xit:
debugStackPop
On Error Resume Next
Exit Function
catchError:
Select Case Err
Case 71
'(Do nothing because we are not in a position to pop error messages)
' MsgBox "That path refers to a floppy disk. Please insert the disk.", 49,
"Insert Disk"
Case 76
'(We can expect 76 if no file found)
Case 68
'(Do nothing because we are not in a position to pop error messages)
' MsgBox "The system has reported that drive " & UCase$(Left$(th eFilePath,
2)) & " is unavailable." & skipLine & "One possibility is that you specified the
wrong drive; another is that there is a problem with your LAN logon.", 16,
"Cannot find Drive"
Case Else
errorLogWrite "Unexpected error encountered when checking for existance of
a file."
End Select
Resume fileExist_xit
End Function
Private Function validateErrorFi lePath(ByVal theFilePath As String) As Boolean
5000 callStackPush mModuleName, "validateErrorF ilePath"
5001 On Error GoTo catchError
' PURPOSE: To validate the error log path by seeing if we can create a file.
'
' NOTES: 1) We cannot log an error message because the main use of this
routine
' is to validate the error log path. Instead, we append a message
' to .ErrorList.
' 2) We do the Dir$() without error trapping because it will generate
' an error 52 in addition to returning an empty string if we feed it
' a UNC with non-existant file name.
' 3) If we feed a path lacking either drive letter or server\sharenam e
' to "Open" it seems to handle it without error, but we can't figure
' out where the file was created.
' Therefore we check for a drive or UNC first.
5002 Dim x As Integer
Dim myErl As Long
Dim myNumber As Long
Dim mySource As String
Dim myDescription As String
Dim myString As String
Dim myReturnValue As String
Const pathNotFound = 76
Const badFileNameOrNu mber = 52
Const pathFileAccessE rror = 75
5010 If (Mid$(theFilePa th, 2, 1) = ":") Or (Left$(theFileP ath, 2) = "\\") Then
On Error Resume Next
myReturnValue = Dir$(theFilePat h)
On Error GoTo catchError
5020 If Len(myReturnVal ue) > 0 Then
5021 validateErrorFi lePath = True
5029 Else
5030 x = FreeFile
5031 Open theFilePath For Append As x
5032 Close x
5033 Kill theFilePath
5039 validateErrorFi lePath = True
598 End If
5999 End If
Xit:
callStackPop
On Error Resume Next
Exit Function
catchError:
myErl = Erl
myNumber = Err.Number
mySource = Err.Source
myDescription = Err.description
On Error Resume Next
Select Case myNumber
Case pathNotFound, badFileNameOrNu mber, pathFileAccessE rror
'(do nothing, these errors simply confirm that the path is bad)
Case Else
myString = "PROGRAM ERROR @" & mySource & " -- Error# " &
Format$(myNumbe r, "0000") & ": " & myDescription & "."
errorListAdd myString
End Select
Resume Xit
End Function
Private Function driverGetPointA rray(ByVal theDeviceCapabi lityType As
mDeviceCapabili tyTypes, ByRef thePrinter As mPrinterStruct) As mXyPoint()
callStackPush mModuleName, "driverGetPoint Array"
On Error GoTo catchError
' PURPOSE: To retrieve an array of x-y coordinates type values (each one is a
pair
' of integers) from a printer's driver
' ACCEPTS: - A constant telling what capability we are looking for. e.g.
Printer resolution
' - A printer struct containing name, port of printer
' RETURNS: An array of the coordinates found
'
' NOTES: 1) The DeviceCapabilit ies() API call returns -1 upon failure
Dim myPointList() As mXyPoint
Dim myListCount As Long
Dim L As Long
myListCount = DeviceCapabilit iesLng(thePrint er.DeviceName, thePrinter.Port ,
theDeviceCapabi lityType, 0, 0)
If myListCount = -1 Then
errorLogWrite "Unable to retrieve device capability count for type" &
Str(theDeviceCa pabilityType)
Else
If myListCount > 0 Then
ReDim myPointList(0 To myListCount - 1)
L = DeviceCapabilit iesAny(thePrint er.DeviceName, thePrinter.Port ,
theDeviceCapabi lityType, myPointList(0), 0)
If L = -1 Then
errorLogWrite "Unable to retrieve device capability list for type" &
Str(theDeviceCa pabilityType)
End If
End If
End If
driverGetPointA rray = myPointList
Xit:
callStackPop
On Error Resume Next
Exit Function
catchError:
errorLogWrite ""
Resume Xit
End Function
Private Sub validatePrinter PropsAndCapabil ities(ByRef thePrinter As
mPrinterStruct)
callStackPush mModuleName, "validatePrinte rPropsAndCapabi lities"
On Error GoTo catchError
' PURPOSE: To check printer options supplied by caller against possible
capapbilities
' AND against capabilities supported by chosen printer
' ACCEPTS: Struct containing name, port of chosen printer
' SETS: - mCurErrorCount (incremented for each incompatibility found via
'errorListAdd')
' - mCurErrorList (an error description added for each incompatability
found via 'errorListAdd')
'
Dim myPrinterDm As mPrtDevModeStru ct
Dim myPointArray() As mXyPoint
Dim myCurRez As mXyPoint
Dim myStringArray() As String
Dim myArraySize As Long
Dim capabilitySuppo rted As Boolean
Dim valuesFound As String
Dim myMsg As String
Dim B As Boolean
Dim L As Long
Dim i As Integer
Const myIndent = 6
Const myDelim = ", "
myPrinterDm = printerDevModeG et(thePrinter.D eviceName)
With mCurDevMode
' ---------------------------------------------
' Collate
Select Case .intCollate
Case rpCollate_False
'(do nothing)
Case rpCollate_True
If myPrinterDm.int Collate <> rpCollate_True Then
errorListAdd ".Collate: Collating requested, but printer " &
thePrinter.Devi ceName & " does not support collating. Value specified = " &
Str(.intCollate ) & ". "
End If
Case Else
errorListAdd ".Collate: Values allowed = " & Format$(rpColla te_True,
"#0") & " = True" & myDelim & Format$(rpColla te_False, "#0") & " = False.
Value specified = " & Str(.intCollate ) & ". "
End Select
' ---------------------------------------------
' Color
Select Case .intColor
Case rpColor_Monochr ome
'(do nothing)
Case rpColor_Color
If myPrinterDm.int Color <> rpColor_Color Then
errorListAdd ".Color: Color printing requested, but printer " &
thePrinter.Devi ceName & " does not support color printing."
End If
Case Else
errorListAdd ".Color: Values allowed = " & Format$(rpColor _Monochrome,
"#0") & " = Monochrome" & myDelim & Format$(rpColor _Color, "#0") & " = Color.
Value specified = " & Str(.intColor) & ". "
End Select
' ---------------------------------------------
' Copies
L = driverGetNumeri cValue(dcCopies , thePrinter)
If L < .intCopies Then
errorListAdd ".Copies: Max copies allowed by printer " &
thePrinter.Devi ceName & " = " & Format$(L, "#0") & ". Value specified = " &
Format$(.intCop ies, "#0") & "."
End If
' ---------------------------------------------
' DefaultSource NOT CHECKED AGAINST PRINTER CAPABILITIES
Select Case .intDefaultSour ce
Case rpSrc_Upper, rpSrc_OnlyOne, rpSrc_Lower, rpSrc_Middle,
rpSrc_Manual_Fe ed, rpSrc_Envelope, _
rpSrc_Envelope_ Manual_Feed, rpSrc_Auto, rpSrc_Tractor,
rpSrc_Small_For mat, rpSrc_Large_For mat, _
rpSrc_Large_Cap acity, rpSrc_Cassette, rpSrc_Form_Sour ce, rpSrc_User
'(do nothing)
Case Else
errorListAdd ".DefaultSource : Values allowed = " & _
Format$(rpSrc_U pper, "#0") & " = Upper tray" & myDelim & _
Format$(rpSrc_O nlyOne, "#0") & " = Only Tray" & myDelim & _
Format$(rpSrc_L ower, "#0") & " = Lower Tray" & myDelim & _
Format$(rpSrc_M iddle, "#0") & " = Middle Tray" & myDelim & _
Format$(rpSrc_M anual_Feed, "#0") & " = Manual Feed" & myDelim & _
Format$(rpSrc_E nvelope, "#0") & " = Envelope (from tray)" & myDelim
& _
Format$(rpSrc_E nvelope_Manual_ Feed, "#0") & " = Envelope (manually
fed)" & myDelim & _
Format$(rpSrc_A uto, "#0") & " = Auto" & myDelim & _
Format$(rpSrc_T ractor, "#0") & " = Tractor" & myDelim & _
Format$(rpSrc_S mall_Format, "#0") & " = Small-Format Tray" &
myDelim & _
Format$(rpSrc_L arge_Format, "#0") & " = Large-Format Tray" &
myDelim & _
Format$(rpSrc_L arge_Capacity, "#0") & " = Large-Capacity Tray" &
myDelim & _
Format$(rpSrc_C assette, "#0") & " = Cassette" & myDelim & _
Format$(rpSrc_F orm_Source, "#0") & " = Form Tray" & myDelim & _
Format$(rpSrc_U ser, "#0") & " = User-Specified." & _
" Value specified = " & Str(.intDefault Source) & ". "
End Select
' ---------------------------------------------
' Duplex
If Not IsNull(.intDupl ex) Then
If (.intDuplex < 1) Or (.intDuplex > 3) Then
errorListAdd ".Duplex: Values allowed = 1 (simplex), 2 (horizontal),
and 3 (vertical). Value specified =" & Str(.intDuplex) & "."
Else
If (.intDuplex > 1) And (Not myPrinterDm.int Duplex > 1) Then
errorListAdd ".Duplex: Duplex option requested, but " &
thePrinter.Devi ceName & " does not support duplexing. Value specified =" &
Str(.intDuplex) & "."""
End If
End If
End If
' ---------------------------------------------
' Orientation (WE ASSUME THAT ALL PRINTERS SUPPORT PORTRAIT)
Select Case .intOrientation
Case rporient_Portra it
'(do nothing)
Case rporient_landsc ape
L = driverGetNumeri cValue(dcOrient ation, thePrinter)
If L = 0 Then
errorListAdd ".Orientati on: Landscape requested, but " &
thePrinter.Devi ceName & " does not support landscape orientation. Value
specified =" & Str(.intOrienta tion) & "."""
End If
Case Else
errorListAdd ".Orientati on: Values allowed = " &
Format$(rporien t_Portrait, "#0") & " = Portrait" & myDelim &
Format$(rporien t_landscape, "#0") & " = Landscape. Value specified = " &
Str(.intOrienta tion) & ". "
End Select
' ---------------------------------------------
' PaperLength (NOT IMPLEMENTED)
' ---------------------------------------------
' PaperSize
Select Case .intPaperSize
Case rpSrc_Upper, rpSrc_OnlyOne, rpSrc_Lower, rpSrc_Middle,
rpSrc_Manual_Fe ed, rpSrc_Envelope, _
rpSrc_Envelope_ Manual_Feed, rpSrc_Auto, rpSrc_Tractor,
rpSrc_Small_For mat, rpSrc_Large_For mat, _
rpSrc_Large_Cap acity, rpSrc_Cassette, rpSrc_Form_Sour ce, rpSrc_User
'(do nothing)
Case Else
myMsg = ".PaperSize : Values allowed = "
myMsg = myMsg & Format$(rpPaper _Letter, "#0") & " = Letter 8 1/2 x
11 in" & myDelim
myMsg = myMsg & Format$(rpPaper _LetterSmall, "#0") & " = Letter
Small 8 1/2 x 11 in" & myDelim
myMsg = myMsg & Format$(rpPaper _Tabloid, "#0") & " = Tabloid 11 x
17" & myDelim
myMsg = myMsg & Format$(rpPaper _Ledger, "#0") & " = Ledger 17 x 11"
& myDelim
myMsg = myMsg & Format$(rpPaper _Legal, "#0") & " = Legal 8 1/2 x
14" & myDelim
myMsg = myMsg & Format$(rpPaper _Statement, "#0") & " = Statement 5
1/2 x 8 1/2" & myDelim
myMsg = myMsg & Format$(rpPaper _Executive, "#0") & " = Executive 7
1/4 x 10 1/2" & myDelim
myMsg = myMsg & Format$(rpPAPER _A3, "#0") & " = A3 297 x 420 mm" &
myDelim
myMsg = myMsg & Format$(rpPaper _A4, "#0") & " = A4 210 x 297 mm" &
myDelim
myMsg = myMsg & Format$(rpPaper _A4_Small, "#0") & " = A4 Small 210
x 297 mm" & myDelim
myMsg = myMsg & Format$(rpPaper _A5, "#0") & " = A5 148 x 210 mm" &
myDelim
myMsg = myMsg & Format$(rpPaper _B4, "#0") & " = B4 (JIS) 250 x 354
mm" & myDelim
myMsg = myMsg & Format$(rpPaper _B5, "#0") & " = B5 (JIS) 182 x 257
mm" & myDelim
myMsg = myMsg & Format$(rpPaper _FOLIO, "#0") & " = Folio 8 1/2 x
13" & myDelim
myMsg = myMsg & Format$(rpPaper _QUARTO, "#0") & " = Quarto 215 x
275 mm" & myDelim
myMsg = myMsg & Format$(rpPaper _10X14, "#0") & " = 10x14 in" &
myDelim
myMsg = myMsg & Format$(rpPaper _11X17, "#0") & " = 11x17 in" &
myDelim
myMsg = myMsg & Format$(rpPaper _NOTE, "#0") & " = Note 8 1/2 x 11
in" & myDelim
myMsg = myMsg & Format$(rpPaper _Env_9, "#0") & " = Envelope #9 3
7/8 x 8 7/8" & myDelim
myMsg = myMsg & Format$(rpPaper _Env_10, "#0") & " = Envelope #10 4
1/8 x 9 1/2" & myDelim
myMsg = myMsg & Format$(rpPaper _Env_11, "#0") & " = Envelope #11 4
1/2 x 10 3/8" & myDelim
myMsg = myMsg & Format$(rpPaper _Env_12, "#0") & " = Envelope #12 4
\276 x 11" & myDelim
myMsg = myMsg & Format$(rpPaper _Env_14, "#0") & " = Envelope #14 5
x 11 1/2" & myDelim
myMsg = myMsg & Format$(rpPaper _C_Sheet, "#0") & " = C size sheet"
& myDelim
myMsg = myMsg & Format$(rpPaper _D_Sheet, "#0") & " = D size sheet"
& myDelim
myMsg = myMsg & Format$(rpPaper _E_Sheet, "#0") & " = E size sheet"
& myDelim
myMsg = myMsg & Format$(rpPaper _Env_DL, "#0") & " = Envelope DL 110
x 220mm" & myDelim
myMsg = myMsg & Format$(rpPaper _Env_C5, "#0") & " = Envelope C5 162
x 229 mm" & myDelim
myMsg = myMsg & Format$(rpPaper _Env_C3, "#0") & " = Envelope C3
324 x 458 mm" & myDelim
myMsg = myMsg & Format$(rpPaper _Env_C4, "#0") & " = Envelope C4
229 x 324 mm" & myDelim
myMsg = myMsg & Format$(rpPaper _Env_C6, "#0") & " = Envelope C6
114 x 162 mm" & myDelim
myMsg = myMsg & Format$(rpPaper _Env_B4, "#0") & " = Envelope B4
250 x 353 mm" & myDelim
myMsg = myMsg & Format$(rpPaper _Env_B5, "#0") & " = Envelope B5
176 x 250 mm" & myDelim
myMsg = myMsg & Format$(rpPaper _Env_B6, "#0") & " = Envelope B6
176 x 125 mm" & myDelim
myMsg = myMsg & Format$(rpPaper _Env_ITALY, "#0") & " = Envelope 110
x 230 mm" & myDelim
myMsg = myMsg & Format$(rpPaper _Env_Monarch, "#0") & " = Envelope
Monarch 3.875 x 7.5" & myDelim
myMsg = myMsg & Format$(rpPaper _Env_Personal, "#0") & " = Envelope
3 5/8 x 6 1/2" & myDelim
myMsg = myMsg & Format$(rpPaper _FanFold_US, "#0") & " = US Std
Fanfold 14 7/8 x 11" & myDelim
myMsg = myMsg & Format$(rpPaper _FanFold_Std_Ge rman, "#0") & " =
German Std Fanfold 8 1/2 x 12" & myDelim
myMsg = myMsg & Format$(rpPaper _FanFold_Lgl_Ge rman, "#0") & " =
German Legal Fanfold 8 1/2 x 13" & myDelim
myMsg = myMsg & Format$(rpPaper _ISO_B4, "#0") & " = B4 (ISO) 250 x
353 mm" & myDelim
myMsg = myMsg & Format$(rpPaper _Japanese_Postc ard, "#0") & " =
Japanese Postcard 100 x 148 mm" & myDelim
myMsg = myMsg & Format$(rpPaper _9X11, "#0") & " = 9 x 11" & myDelim
myMsg = myMsg & Format$(rpPaper _10X11, "#0") & " = 10 x 11" &
myDelim
myMsg = myMsg & Format$(rpPaper _15X11, "#0") & " = 15 x 11" &
myDelim
myMsg = myMsg & Format$(rpPaper _Env_Invite, "#0") & " = Envelope,
Invitation 220 x 220 mm" & myDelim
myMsg = myMsg & Format$(rpPaper _Letter_Extra, "#0") & " = Letter
Extra 9 x 12" & myDelim
myMsg = myMsg & Format$(rpPaper _LEGAL_Extra, "#0") & " = Legal
Extra 9 x 15" & myDelim
myMsg = myMsg & Format$(rpPaper _Tabloid_Extra, "#0") & " = Tabloid
Extra 11.69 x 18" & myDelim
myMsg = myMsg & Format$(rpPaper _A4_Extra, "#0") & " = A4 Extra 9.27
x 12.69" & myDelim
myMsg = myMsg & Format$(rpPaper _Letter_Transve rse, "#0") & " = A4
Transverse 210 x 297 mm" & myDelim
myMsg = myMsg & Format$(rpPaper _Letter_Extra_T ransverse, "#0") & "
= Letter Extra Transverse 9\275 x 12" & myDelim
myMsg = myMsg & Format$(rpPaper _A_Plus, "#0") & " =
SuperA/SuperA/A4 227 x 356 mm" & myDelim
myMsg = myMsg & Format$(rpPaper _B_Plus, "#0") & " =
SuperB/SuperB/A3 305 x 487 mm" & myDelim
myMsg = myMsg & Format$(rpPaper _Letter_Plus, "#0") & " = Letter
Plus 8.5 x 12.69" & myDelim
myMsg = myMsg & Format$(rpPaper _A4_Plus, "#0") & " = A4 Plus 210 x
330 mm" & myDelim
myMsg = myMsg & Format$(rpPaper _A5_Transverse, "#0") & " = A5
Transverse 148 x 210 mm" & myDelim
myMsg = myMsg & Format$(rpPaper _B5_Transverse, "#0") & " = B5 (JIS)
Transverse 182 x 257 mm" & myDelim
myMsg = myMsg & Format$(rpPaper _A3_Extra, "#0") & " = A3 Extra 322
x 445 mm" & myDelim
myMsg = myMsg & Format$(rpPaper _A5_Extra, "#0") & " = A5 Extra 174
x 235 mm" & myDelim
myMsg = myMsg & Format$(rpPaper _B5_Extra, "#0") & " = B5 (ISO)
Extra 201 x 276 mm" & myDelim
myMsg = myMsg & Format$(rpPaper _A2, "#0") & " = A2 420 x 594 mm" &
myDelim
myMsg = myMsg & Format$(rpPaper _A3_Transverse, "#0") & " = A3
Transverse 297 x 420 mm" & myDelim
myMsg = myMsg & Format$(rpPaper _A3_Extra_Trans verse, "#0") & " = A3
Extra Transverse 322 x 445 mm" & myDelim
myMsg = myMsg & Format$(rpPaper _User, "#0") & " = (user-defined)" &
myDelim
myMsg = myMsg & " Value specified = " & Str(.intPaperSi ze) & ". "
errorListAdd myMsg
End Select
' ---------------------------------------------
' PaperWidth (NOT IMPLEMENTED)
' ---------------------------------------------
' PrintQuality
If .intPrintQualit y > 0 And (Not .intYResolution > 0) Then
errorListAdd ".PrintQual ity: A positive value in .PrintQuality is
regarded as an x-axis resolution and must be accompanied by a positive value in
..YResolution."
Else
Select Case .intPrintQualit y
Case rpQual_Draft, rpQual_Low, rpQual_Medium, rpQual_High
'(do nothing, these are allowed values)
Case Else
errorListAdd ".PrintQual ity: Allowed negative values are: -1 =
Draft, -2 = Low, -3 = Medium, -4 = High. Value specified = " &
Str(.intPrintQu ality) & ". "
End Select
End If
' ---------------------------------------------
' ScaleAmount (NOT IMPLEMENTED)
' ---------------------------------------------
' TrueType Option (NOT IMPLEMENTED)
' ---------------------------------------------
' YResolution (in conjunction w/PrintQuality)
If .intYResolution > 0 And (Not .intPrintQualit y > 0) Then
errorListAdd ".YResoluti on: If present, YResolution must be accompanied
by a positive value in .PrintQuality, which will function as the x-axis
resolution."
Else
If (.intYResolutio n > 0) And (.intPrintQuali ty > 0) Then
myCurRez.x = .intPrintQualit y
myCurRez.Y = .intYResolution
myPointArray = driverGetPointA rray(dcEnumReso lutions, thePrinter)
myArraySize = UBound(myPointA rray) - 1
capabilitySuppo rted = False
For i = 0 To myArraySize
If (myPointArray(i ).x = myCurRez.x) And (myPointArray(i ).Y =
myCurRez.Y) Then
capabilitySuppo rted = True
End If
Next i
If capabilitySuppo rted = False Then
valuesFound = ""
For i = 0 To myArraySize
If Len(valuesFound ) > 0 Then
valuesFound = valuesFound & ","
End If
valuesFound = valuesFound & Space(myIndent) &
Format$(myPoint Array(i).x, "#0") & "x" & Format$(myPoint Array(i).Y, "#0")
Next i
errorListAdd ".PrintQual ity: Unsupported resolution. Resolutions
supported are " & valuesFound & ". Resolution specified = " &
Format$(myCurRe z.x, "#0") & "x" & Format$(myCurRe z.Y, "#0") & "."
End If
End If
End If
End With
Xit:
callStackPop
On Error Resume Next
Exit Sub
catchError:
errorLogWrite ""
Resume Xit
End Sub
Private Function driverGetString Array(theDevice CapabilityType As
mDeviceCapabili tyTypes, ByRef thePrinter As mPrinterStruct) As String()
callStackPush mModuleName, "driverGetStrin gArray"
On Error GoTo catchError
' PURPOSE: To retrieve an array of strings from a printer's driver
' ACCEPTS: - A constant telling what capability we are looking for. e.g.
Printer resolution
' - A printer struct containing name, port of printer
' RETURNS: Array of strings e.g. Paper Names, File Dependencies, Bin Names
'
' NOTES: 1)We use the DeviceCapabilit ies API call to retrieve a sting of
whatever capabilities
' we're looking for. The raw string is padded with nulls so it
contains fixed-length
' chunks.
' 2) Once we get that string, we use 'StripNulls(Mid $())' to parse it
into our string array.
Dim myStringArray() As String
Dim myListCount As Long
Dim myBuffer As String
Dim L As Long
Dim i As Integer
Dim myStringSize As Integer
Dim okToProceed As Boolean
Const apiCallFailed = -1
Select Case theDeviceCapabi lityType
Case dcPaperNames
myStringSize = mDriverStringLe nPaperName
okToProceed = True
Case dcBinNames
myStringSize = mDriverStringLe nBinName
okToProceed = True
Case dcFileDependenc ies
myStringSize = mDriverStringLe nBinDependency
okToProceed = True
Case Else
errorLogWrite "Unexpected list type:" & Str(theDeviceCa pabilityType)
End Select
If okToProceed = True Then
myListCount = DeviceCapabilit iesLng(thePrint er.DeviceName, thePrinter.Port ,
theDeviceCapabi lityType, 0, 0)
If myListCount = apiCallFailed Then
errorLogWrite "Unable to retrieve list count for " &
Str(theDeviceCa pabilityType)
Else
If myListCount > 0 Then
ReDim myStringArray(0 To myListCount - 1)
myBuffer = String$(myStrin gSize * myListCount, 0)
L = DeviceCapabilit iesStr(thePrint er.DeviceName, thePrinter.Port ,
theDeviceCapabi lityType, myBuffer, 0)
If L = apiCallFailed Then
errorLogWrite "Unable to retrieve list for " &
Str(theDeviceCa pabilityType)
Else
For i = 0 To myListCount - 1
myStringArray(i ) = stripNulls(Mid$ (myBuffer, i * myStringSize
+ 1, myStringSize))
Next i
End If
End If
End If
driverGetString Array = myStringArray
End If
Xit:
callStackPop
On Error Resume Next
Exit Function
catchError:
errorLogWrite ""
Resume Xit
End Function
Private Function stripNulls(ByVa l theOriginalStri ng As String) As String
callStackPush mModuleName, "stripNulls "
On Error GoTo catchError
' PURPOSE: To remove any nulls from a string
' ACCEPTS: The target string
' RETURNS: Target string with any nulls removed
If InStr(1, theOriginalStri ng, Chr(0), vbTextCompare) Then
theOriginalStri ng = Mid(theOriginal String, 1, InStr(theOrigin alString,
Chr(0)) - 1)
End If
stripNulls = theOriginalStri ng
Xit:
debugStackPop
On Error Resume Next
Exit Function
catchError:
bugAlert True, ""
Resume Xit
End Function
Private Function driverGetNumeri cValue(ByVal theDeviceCapabi lityType As
mDeviceCapabili tyTypes, ByRef thePrinter As mPrinterStruct) As Long
callStackPush mModuleName, "driverGetNumer icValue"
On Error GoTo catchError
' PURPOSE: To retrieve an array of strings from a printer's driver
' ACCEPTS: - A constant telling what capability we are looking for. e.g. Copies
' - A printer struct containing name, port of printer
' RETURNS: A 'Long' value
'F
' NOTES: 1) The DeviceCapabilit ies() API call returns -1 upon failure
Dim L As Long
L = DeviceCapabilit iesLng(thePrint er.DeviceName, thePrinter.Port ,
theDeviceCapabi lityType, 0, 0)
If L = -1 Then
errorLogWrite "Unable to retrieve device capability value for " &
Str(theDeviceCa pabilityType)
End If
driverGetNumeri cValue = L
Xit:
callStackPop
On Error Resume Next
Exit Function
catchError:
errorLogWrite ""
Resume Xit
End Function
Private Function driverGetIntege rArray(ByVal theDeviceCapabi lityType As
mDeviceCapabili tyTypes, ByRef thePrinter As mPrinterStruct) As Integer()
callStackPush mModuleName, "driverGetInteg erArray"
On Error GoTo catchError
' PURPOSE: To retrieve an array of integers from a printer's driver
' ACCEPTS: - A constant telling what capability we are looking for. e.g. Bin
values
' - A printer struct containing name, port of printer
' RETURNS: A 'Long' value
'
' NOTES: 1) The DeviceCapabilit ies() API call returns -1 upon failure
Dim myIntegerArray( ) As Integer
Dim myListCount As Long
Dim L As Long
myListCount = DeviceCapabilit iesLng(thePrint er.DeviceName, thePrinter.Port ,
theDeviceCapabi lityType, 0, 0)
If myListCount = -1 Then
errorLogWrite "Unable to retrieve list count for " &
Str(theDeviceCa pabilityType)
Else
If myListCount > 0 Then
ReDim myIntegerArray( 0 To myListCount - 1)
L = DeviceCapabilit iesAny(thePrint er.DeviceName, thePrinter.Port ,
theDeviceCapabi lityType, myIntegerArray( 0), 0)
If L = -1 Then
errorLogWrite "Unable to retrieve list for " &
Str(theDeviceCa pabilityType)
End If
End If
End If
driverGetIntege rArray = myIntegerArray
Xit:
callStackPop
On Error Resume Next
Exit Function
catchError:
errorLogWrite ""
Resume Xit
End Function
Private Function driverGetPointV alue(ByVal theDeviceCapabi lityType As
mDeviceCapabili tyTypes, ByRef thePrinter As mPrinterStruct) As mXyPoint
callStackPush mModuleName, "driverGetPoint Value"
On Error GoTo catchError
' PURPOSE: To retrieve a single x/y pair of integers from a printer's driver
' ACCEPTS: - A constant telling what capability we are looking for. e.g. Bin
values
' - A printer struct containing name, port of printer
' RETURNS: An x/y coordinate value
'
' NOTES: 1) The DeviceCapabilit ies() API call returns -1 upon failure
Dim myPoint As mXyPoint
Dim L As Long
Dim myDoubleWord As mDoubleWordStru ct
Dim mySplitWord As mSplitWordStruc t
L = DeviceCapabilit iesLng(thePrint er.DeviceName, thePrinter.Port ,
theDeviceCapabi lityType, 0, 0)
If L = -1 Then
errorLogWrite "Unable to retrieve device capability for type" &
Str(theDeviceCa pabilityType)
End If
myDoubleWord.Va lue = L
LSet mySplitWord = myDoubleWord
myPoint.x = mySplitWord.LoW ord
myPoint.Y = mySplitWord.HiW ord
driverGetPointV alue = myPoint
Xit:
callStackPop
On Error Resume Next
Exit Function
catchError:
errorLogWrite ""
Resume Xit
End Function
Private Function isBool(ByVal theValue As Integer) As Boolean
callStackPush mModuleName, "isBool"
On Error GoTo catchError
' PURPOSE: To determine whether or not the value in question is a boolean
' ACCEPTS: The value
' RETURNS: True if boolean, else false
If Not IsNull(theValue ) Then
If IsNumeric(theVa lue) Then
If ((theValue = 0) Or (theValue = -1)) Then
isBool = True
End If
End If
End If
Xit:
callStackPop
On Error Resume Next
Exit Function
catchError:
errorLogWrite ""
Resume Xit
End Function
Private Function pdfFileNameCrea te(ByVal theGetFileNameF rom As Long, ByVal
theFileNamePref ix As String, ByVal theFileNameSuff ix As String, ByRef theReport
As Report) As String
callStackPush mModuleName, "pdfFileNameCre ate"
On Error GoTo catchError
' PURPOSE: To create the complet DOS path to the PDF file that Acrobat will
create
' ACCEPTS: - A code telling where to get file name from
' - An optional prefix for the file name
' - An optional suffix for the file name
' - A pointer to the report in question
'
' RETURNS: DOS path or empty string, depending upon success
' SETS: - mCurErrorCount (via 'errorListAdd')
' - mCurErrorList (via 'errorListAdd')
Dim myPdfFileName As String
Select Case theGetFileNameF rom
Case rpGetFromReport Name
myPdfFileName = theFileNamePref ix & theReport.Name & theFileNameSuff ix
Case rpGetFromReport Caption
With theReport
If Len(Trim$(.Capt ion & "")) > 0 Then
myPdfFileName = theFileNamePref ix & theReport.Capti on &
theFileNameSuff ix
Else
myPdfFileName = theFileNamePref ix & theReport.Name &
theFileNameSuff ix
End If
End With
Case Else
errorListAdd ".GetPdfFileNam eFrom: Values allowed: 1 = From Report Name,
2 = From Report's .Caption string. Value passed = " & Format$(theGetF ileNameFrom
& "", "#") & ". "
End Select
pdfFileNameCrea te = myPdfFileName
Xit:
callStackPop
On Error Resume Next
Exit Function
catchError:
errorLogWrite ""
Resume Xit
End Function
Private Function extractDirFromF ullPath(theFull Path) As String
callStackPush mModuleName, "extractDirFrom FullPath"
On Error GoTo catchError
' PURPOSE: To extract the directory portion (including final backslash)
' of a full path (i.e. one including file name....)
' ACCEPTS: The full path
' RETURNS: The directory portion of that path, including final backslash
'
' NOTES: It all hinges on the full path ending with a file name
Dim x As Integer
Dim Y As Integer
Dim L As Integer
Dim myDir As String
x = 1
Y = 999
L = Len(theFullPath )
Do While Y > 0
Y = InStr(x, theFullPath, "\")
If Y > 0 Then
L = Y
x = Y + 1
End If
Loop
extractDirFromF ullPath = Left$(theFullPa th, L - 1)
Xit:
callStackPop
On Error Resume Next
Exit Function
catchError:
errorLogWrite ""
Resume Xit
End Function
Private Function extractDirFromF ullPath_elw(the FullPath) As String
On Error GoTo catchError 'NO ERROR LOGGING BECAUSE USED BY ERROR ROUTINES
' PURPOSE: To extract the directory portion (including final backslash)
' of a full path (i.e. one including file name....)
' ACCEPTS: The full path
' RETURNS: The directory portion of that path, including final backslash
'
' NOTES: 1) It all hinges on the full path ending with a file name
Dim x As Integer
Dim Y As Integer
Dim L As Integer
Dim myDir As String
x = 1
Y = 999
L = Len(theFullPath )
Do While Y > 0
Y = InStr(x, theFullPath, "\")
If Y > 0 Then
L = Y
x = Y + 1
End If
Loop
extractDirFromF ullPath_elw = Left$(theFullPa th, L - 1)
Xit:
callStackPop
On Error Resume Next
Exit Function
catchError:
MsgBox "clsReportPrint er: runtime error in extractDirFromF ullPath_elw()"
Resume Xit
End Function
Public Property Get Version() As String
callStackPush mModuleName, "Version"
On Error GoTo catchError
' PURPOSE: - To allow the current version number of this class
' RETURNS: String containing version number
Version = mVersionNumber
Xit:
callStackPop
On Error Resume Next
Exit Property
catchError:
errorLogWrite ""
Resume Xit
End Property
=============== =============== =============== =============== =============== =====
--
PeteCresswell
