By using this site, you agree to our updated Privacy Policy and our Terms of Use. Manage your Cookies Settings.
435,412 Members | 2,882 Online
Bytes IT Community
+ Ask a Question
Need help? Post your question and get tips & solutions from a community of 435,412 IT Pros & Developers. It's quick & easy.

Access expoert reports to PDF using PDF writer 6.0 issues

P: n/a
Hi,

I am automating Access reports to PDF using PDF Writer 6.0. I've
created a DTS package to run the reports and schedule a job to run this
DTS package. If I PC Anywhere into the server on where the job is
running, the job runs sucessfully, PDF files got generated, everything
is good. If I scheduled the job to run at the time that I am not
logged into the server, Access is not able to print to the printer.
The error is pretty generic. It says Cannot print xxx.pdf to xxx
location, would you like to retry?. Is this a PDF Writer printing
permission problem? FYI, the account that I used to run the job is the
same as the account I used to log into the server.
Please help out. Let me know if more explaination is needed.

Thanks.

Nov 13 '05 #1
Share this Question
Share on Google+
11 Replies


P: n/a

"Grasshopper" <am*****@gmail.com> wrote in message
news:11********************@z14g2000cwz.googlegrou ps.com...
Hi,

I am automating Access reports to PDF using PDF Writer 6.0. I've
created a DTS package to run the reports and schedule a job to run this
DTS package. If I PC Anywhere into the server on where the job is
running, the job runs sucessfully, PDF files got generated, everything
is good. If I scheduled the job to run at the time that I am not
logged into the server, Access is not able to print to the printer.
The error is pretty generic. It says Cannot print xxx.pdf to xxx
location, would you like to retry?. Is this a PDF Writer printing
permission problem? FYI, the account that I used to run the job is the
same as the account I used to log into the server.
Please help out. Let me know if more explaination is needed.

Thanks.


How did you get Access to write to PDF? Sorry, just curious...
Nov 13 '05 #2

P: n/a
first you need to set your default printer to PDF printer, and then
DoCmd.OpenReport sReportName, acNormal will do the trick.

Nov 13 '05 #3

P: n/a
Per Grasshopper:
first you need to set your default printer to PDF printer, and then
DoCmd.OpenReport sReportName, acNormal will do the trick.


Maybe you've just touched on the problem.

Sounds like it's using some sort of default from your user id that works...but
when you're not there whatever default values it gets aren't working.
I've always had to use the registry as an API to PDFWriter in order to give it
the specs on where to write the file and what to call it.
--
PeteCresswell
Nov 13 '05 #4

P: n/a
Greetings,

See my post in this newsgroup:

http://groups-beta.google.com/group/...1d9056438b0378

Feedback encouraged / appreciated.

Note: my apologies on the poor text formatting. Haven't gotten the
hang of Google Groups just yet. This might be easier to read:
'
< http://ourworld.cs.com/cyranoVR/autopdf.txt >

Regards,

CyranoVR

Nov 13 '05 #5

P: n/a
Thanks for your reply.

Have you tried to schedule your access to automate the reports using
either Windows Scheduler or SQL Server jobs? I want to make sure this
works before I ask the tech department to install those softwares.
Many thanks.

Nov 13 '05 #6

P: n/a
Thanks for your reply.
Can you give me some code on how to call the API?

Nov 13 '05 #7

P: n/a
Grasshopper wrote:
Thanks for your reply.
Have you tried to schedule your access to automate the reports using
either Windows Scheduler or SQL Server jobs? I want to make sure this works before I ask the tech department to install those softwares.
Many thanks.


Windows Scheduler can in fact execute VBScript files.

In the VBScript, you can automate Microsoft Access like any other
office application. The following code opens an Access database, prints
a report to the default printer, and finally quits Access. Note that
when starting Access using CreateObject(), Access stays invisible by
default.

[Begin Sample VBScript Code]

dim acc
set acc = CreateObject("Access.Application")
with acc
..OpenCurrentDatabase "C:\reporting\Sales\SalesStats.mdb"
..DoCmd.OpenReport "rptMonthlySales"
..Quit
end with
set acc = nothing

[End Sample Code]

Using the Access.Application object, you can control your Access
Database just as you would within a Access VBA module - using functions
like DoCmd.OpenQuery, DoCmd.RunSQL, and the collections Reports, Forms,
etc. etc.

However, you don't have access to the DAO objects such as
Tables,Queries, etc. or ADO recordsets (you have to do a separate
CreateObject() for those) Fortunately, you can just put that code into
a Access module subroutine and run it via the Access.Application.Run()
method. Example:

' Below code is the same as Call PrepareMonthlySalesReport(200412,True)
' from within an Access VBA module.
acc.Run("PrepareMonthlySalesReport","200412","True ")
acc.DoCmd.OpenReport "rptMonthlySales"

See the following KB Article for more information:
ACC: Using Microsoft Access as an Automation Server
http://support.microsoft.com/kb/q147816/

Another cool trick is to switch the default printer back and forth
using the WScript.Network object. Example

Dim net
Set net = CreateObject("WScript.Network")
net.SetDefaultPrinter "GhostScript PDF Printer"
....(print reports from Access as above)
net.SetDefaultPrinter "\\Office\HP1320"
Set net = Nothing

Read more about the Windows Script Host object:
http://msdn.microsoft.com/library/en...ScriptHost.asp

But what if something went wrong? After your routine finishes printing,
you should schedule to run a second VBScript file that uses
FileSystemObject to check that the PDFs exist where you expected them
and were created the same day. If not, you should show a message box,
send an email to yourself...something.

[Untested example code]

Const EXPECTED_REPORT_LOCATION = "C:\Reports\MonthlySalesReport.pdf"
dim fso
dim f ' File object

Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.GetFile(EXPECTED_REPORT_LOCATION")
If f.DateCreated() <> Date() Then
MsgBox "The report didn't print to PDF" ' Or whatever
End If
....

I prefer to store the Names/locations/destinations for my reports in a
database table - rather than hardcoding the information into the
VBScript file. VBScript can use ADO to read database tables...of
course, there's tons of info about that on the web thanks to the
popularity of ASP.

A lot of this may seem "obvious" to some, but I've noticed that a lot
of other information out there involves paid applications like PDF995
and multiple cryptic Win32 API calls. Yuck. Use GhostScript/RedMon
for free and the generously provided Access.Application,
Scripting.FileSystemObject and WScript.Network objects. Your life will
be a lot easier.

* * *

One addendum - if you have a particularly long/timeconsuming report,
you may have to insert a call to the Win32 API function Sleep() after
the DoCmd.OpenReport call. Fortunately, this is one of the easiest
Win32 API functions to use:

HOWTO: Use the Sleep API to Pause Program Execution in a DLL
http://support.microsoft.com/default...b;en-us;260337

Nov 13 '05 #8

P: n/a
Per Grasshopper:
Thanks for your reply.
Can you give me some code on how to call the API?


The registry is the API. You make registry calls to update a couple of fields
and PDFWriter uses those fields.

This is probably wretched excess, but the all the code is here...just slog
through it until you find the part where it prints to PDF. If wrapping gets
too bad, flip an email to 30040120.FatBelly.cotse.net and I'll email you
a copy attached - so there's no text wrapping.
-------------------------------------------------------------
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "clsReportPrinter"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = 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 = "clsReportPrinter"

' 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\Whatever.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....useful, 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_Initialize):
' .PrinterName=(name of PC's 'Default' printer)
' .Collate=False
' .Copies=1
' .Color=Monochrome
' .DefaultSource=Auto
' .Duplex=Simplex
' .GetPdfFileNameFrom=Report's Caption
' .Orientation=Portrait
' .PaperSize=Letter
' .PdfDir=(application's directory)
' .PrinterName=PC's default printer
' .PrintQuality=High
'
' 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 clsReportPrinter.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 clsReportPrinter 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 ReportPrintExample()
'
' Dim myReportPrinter As clsReportPrinter
'
' Set myReportPrinter = New clsReportPrinter
'
' With myReportPrinter
' .ReportName = "rptBillableHoursByDay"
' .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"
' .GetPdfFileNameFrom = rpGetFromReportName
' .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
'
' .GetPdfFileNameFrom = rpGetFromReportCaption
' .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\InvstPrt"
' .Copies = 2
' .Orientation = rpOrient_Landscape
' .PrintReport 'Two copies of
report go to specified printer in landscape orientation.
' If .ErrorCount > 0 Then
' MsgBox .ErrorList, vbCritical, "Print Failed"
' End If
'
' .ReportName = "rptVanguardTimeSheet" '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 adhcDevNamesFixed = 8
Private Const adhcFixedChars = adhcDevNamesFixed / 2

Private Const mDriverStringLenBinName = 24
Private Const mDriverStringLenPaperName = 64
Private Const mDriverStringLenBinDependency = 64

Private Const mFormNameLen = 32
Private Const mPrinterNameLen = 32

'Private Const mCallStackLim = 50
Private Const mCallStackLim = 150
Private mCallStack(mCallStackLim)
Private mCallStackPointer As Integer

Private Const mErrorListMessagePrefix = "- "
Private Const mDevModeFudgeFactor = 2048
Private Const mDevModeSize = 148
Private Const mDevModeSizeLim = mDevModeSize + mDevModeFudgeFactor

Private Type mPrinterStruct
IsDefaultPrinter As Boolean
DeviceName As String
DriverName As String
Port As String
End Type

Private Type mPrtDevModeStruct
strDeviceName(1 To mPrinterNameLen) As Byte
intSpecVersion As Integer
intDriverVersion 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
intDefaultSource 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
lngDisplayFrequency As Long
lngICMMethod As Long
lngICMIntent As Long
lngMediaType As Long
lngDitherType As Long
lngReserved1 As Long
lngReserved2 As Long
bytDriverExtra(1 To mDevModeFudgeFactor) As Byte
End Type

Private Type mDevModeStringStruct
strDevMode As String * mDevModeSizeLim
End Type

Private Type mDevNamesOffsetInfoStruct
DriverOffset As Integer
DeviceOffset As Integer
OutputOffset As Integer
IsDefaultPrinter As Integer
End Type

Private Type mDevNamesOffsetStringStruct
strDevInfo As String * adhcFixedChars
End Type

Private Type mDoubleWordStruct
Value As Long
End Type

Private Type mSplitWordStruct
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_DefaultSource = &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_OUTLINE = 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_Monochrome = 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_Feed = 4
rpSrc_Envelope = 5
rpSrc_Envelope_Manual_Feed = 6
rpSrc_Auto = 7
rpSrc_Tractor = 8
rpSrc_Small_Format = 9
rpSrc_Large_Format = 10
rpSrc_Large_Capacity = 11
rpSrc_Cassette = 14
rpSrc_Form_Source = 15
rpSrc_User = 256
End Enum

Public Enum rpDuplex ' Constants for Duplex property
rpDuplex_Simplex = 1
rpDuplex_Vertical = 2
rpDuplex_Horizontal = 3
End Enum

Public Enum rpGetPdfFileNameFrom
rpGetFromReportName = 1
rpGetFromReportCaption = 2
End Enum

Public Enum rpOrientation ' Constants for Orientation
property
rporient_Portrait = 1
rporient_landscape = 2
End Enum

Public Enum rpPaperSize ' Constants for PaperSize property
rpPaper_Letter = 1 ' Letter 8 1/2 x 11
rpPaper_LetterSmall = 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_Statement = 6 ' Statement 5 1/2 x 8 1/2
rpPaper_Executive = 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_Small = 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_ITALY = 36 ' Envelope 110 x 230 mm
rpPaper_Env_Monarch = 37 ' Envelope Monarch 3.875 x 7.5
rpPaper_Env_Personal = 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_Japanese_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_Invite = 47 ' Envelope Invite 220 x 220 mm
rpPaper_Reserved_48 = 48 ' RESERVED--DO NOT USE
rpPaper_Reserved_49 = 49 ' RESERVED--DO NOT USE
rpPaper_Letter_Extra = 50 ' Letter Extra 9 x 12
rpPaper_LEGAL_Extra = 51 ' Legal Extra 9 x 15
rpPaper_Tabloid_Extra = 52 ' Tabloid Extra 11.69 x 18
rpPaper_A4_Extra = 53 ' A4 Extra 9.27 x 12.69
rpPaper_Letter_Transverse = 54 ' Letter Transverse 8 \275 x 11
rpPaper_A4_Transverse = 55 ' A4 Transverse 210 x 297 mm
rpPaper_Letter_Extra_Transverse = 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_Transverse = 61 ' A5 Transverse 148 x 210 mm
rpPaper_B5_Transverse = 62 ' B5 (JIS) Transverse 182 x 257 mm
rpPaper_A3_Extra = 63 ' A3 Extra 322 x 445 mm
rpPaper_A5_Extra = 64 ' A5 Extra 174 x 235 mm
rpPaper_B5_Extra = 65 ' B5 (ISO) Extra 201 x 276 mm
rpPaper_A2 = 66 ' A2 420 x 594 mm
rpPaper_A3_Transverse = 67 ' A3 Transverse 297 x 420 mm
rpPaper_A3_Extra_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_Outline = 4
'End Enum

Private mCurView As Integer
Private mCurPdfDir As String
Private mCurFilter As String
Private mCurDevMode As mPrtDevModeStruct
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 mCurErrorLogPath As String
Private mCurLaunchAcrobat As Boolean
Private mCurGetPdfFileNameFrom As Long
Private mCurShowPdfRegistryInfo As Boolean
Private mCurReportFileNamePrefix As String
Private mCurReportFileNameSuffix As String

Public Enum rpView
rpViewNormal = acViewNormal
rpViewPreview = acViewPreview
End Enum

Private Declare Function ClosePrinter Lib "winspool.drv" (ByVal hPrinter As
Long) As Long
Private Declare Function DocumentProperties Lib "winspool.drv" Alias
"DocumentPropertiesA" (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 "GetComputerNameA"
(ByVal lpBuffer As String, nSize As Long) As Long
Private Declare Function GetProfileSection Lib "kernel32" Alias
"GetProfileSectionA" (ByVal lpAppName As String, ByVal lpReturnedString As
String, ByVal lngSize As Long) As Long
Private Declare Function GetProfileString Lib "kernel32" Alias
"GetProfileStringA" (ByVal lpAppName As String, ByVal lpKeyName As String, ByVal
lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long) As
Long
Private Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA"
(ByVal lpBuffer As String, nSize As Long) As Long
Private Declare Function OpenPrinter Lib "winspool.drv" Alias "OpenPrinterA"
(ByVal pPrinterName As String, phPrinter As Long, ByVal pDefault As Long) As
Long

Private Declare Function DeviceCapabilitiesAny Lib "winspool.drv" Alias
"DeviceCapabilitiesA" (ByVal strDeviceName As String, ByVal strPort As String,
ByVal lngIndex As Long, lpOutput As Any, ByVal lngDevMode As Long) As Long
Private Declare Function DeviceCapabilitiesLng Lib "winspool.drv" Alias
"DeviceCapabilitiesA" (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 DeviceCapabilitiesStr Lib "winspool.drv" Alias
"DeviceCapabilitiesA" (ByVal strDeviceName As String, ByVal strPort As String,
ByVal lngIndex As Long, ByVal strOutput As String, ByVal lngDevMode As Long) As
Long

Private Enum mDeviceCapabilityTypes ' 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
dcEnumResolutions = 13
dcFileDependencies = 14
dcTrueType = 15
dcPaperNames = 16
dcOrientation = 17
dcCopies = 18
End Enum

Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal lngHKey As Long)
As Long
Private Declare Function RegCreateKeyEx Lib "advapi32.dll" Alias
"RegCreateKeyExA" (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 lpSecurityAttributes As Long, phkResult As Long,
lpdwDisposition As Long) As Long
Private Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA"
(ByVal lngHKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal
samDesired As Long, phkResult As Long) As Long
Private Declare Function RegQueryValueExA Lib "advapi32.dll" (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 RegQueryValueExLong Lib "advapi32.dll" Alias
"RegQueryValueExA" (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 RegQueryValueExString Lib "advapi32.dll" Alias
"RegQueryValueExA" (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 RegSetValueExLong Lib "advapi32.dll" 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 RegSetValueExString Lib "advapi32.dll" 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 mRegHKeyClassesRoot = &H80000000
'Private Const mRegHKeyLocalMachine = &H80000002
Private Const mRegHKeyCurrentUser = &H80000001
Private Const mPdfWriterKeyName = "Software\Adobe\Acrobat PDFWriter"

Private Const mRegOptionNonVolatile = 0
Private Const mRregKeyAllAccess = &H3F
Private Const mRegSz As Long = 1
Private Const mRegDWord As Long = 4
Private Const mRegKeyQueryValue = &H1
'

Private Sub Class_Initialize()
callStackPush mModuleName, "Class_Initialize"
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.

printerArrayLoad

mCurView = rpViewNormal
mCurPdfDir = extractDirFromFullPath(Application.CurrentDb.Name)
mCurPrinterName = printerDefaultGet.DeviceName
mCurGetPdfFileNameFrom = rpGetFromReportCaption

If Len(mCurPrinterName) = 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_Monochrome
.intDefaultSource = rpSrc_Auto
.intDuplex = rpDuplex_Simplex
.intOrientation = rporient_Portrait
.intPaperSize = rpPaper_Letter
.intPrintQuality = 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 GetPdfFileNameFrom(ByVal theValue As rpGetPdfFileNameFrom)
callStackPush mModuleName, "GetPdfFileNameFrom"
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.

mCurGetPdfFileNameFrom = theValue

Xit:
callStackPop
On Error Resume Next
Exit Property

catchError:
errorLogWrite ""
Resume Xit
End Property
Public Property Let ReportName(ByVal 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 ReportFileNamePrefix(ByRef theValue As String)
callStackPush mModuleName, "ReportFileNamePrefix"
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

mCurReportFileNamePrefix = theValue

Xit:
callStackPop
On Error Resume Next
Exit Property

catchError:
errorLogWrite ""
Resume Xit
End Property
Public Property Let ReportFileNameSuffix(ByRef theValue As String)
callStackPush mModuleName, "ReportFileNameSuffix"
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

mCurReportFileNameSuffix = theValue

Xit:
callStackPop
On Error Resume Next
Exit Property

catchError:
errorLogWrite ""
Resume Xit
End Property
Public Property Let PrinterName(ByRef theValue As String)
callStackPush mModuleName, "PrinterName"
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\INVHP5SI

mCurPrinterName = theValue

Xit:
callStackPop
On Error Resume Next
Exit Property

catchError:
errorLogWrite ""
Resume Xit
End Property
Public Sub PrintReport()
6000 callStackPush mModuleName, "PrintReport"
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 validatePrinterPropsAndCapabilities()
' - 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 mPrtDevModeStruct
Dim myByteArray() As Byte

Dim myGotPdf As Boolean
Dim myPdfFileName As String
Dim myPdfRegistryInfo As String

Const noSuchReport = 2103

6010 If Len(mCurErrorLogPath) > 0 Then 'This should never happen because we
default the path to application's directory
6011 If validateErrorFilePath(mCurErrorLogPath) = False Then
6012 errorListAdd ".ErrorLogPath: Unable to create the error log file
using path specified. Could one or more of the path's directories be missing?
Path specified = '" & mCurErrorLogPath & "'."
6013 End If
6019 End If

6020 If Len(mCurPrinterName) > 0 Then
6021 myPrinter = printerGet(mCurPrinterName)
6022 If Len(myPrinter.DeviceName) & "" = 0 Then
6023 errorListAdd ".PrinterName: Printer '" & mCurPrinterName & "' is not
installed on this PC.'"
6024 Else
6025 validatePrinterPropsAndCapabilities myPrinter
6026 End If
6029 Else 'we probably shouldn't get this far
with no printer name, but might as well CYA...
6030 errorListAdd ".PrinterName: 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(mCurReportName) = 0 Then
6042 errorListAdd ".ReportName: 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(mCurReportName)
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 ".ReportName: 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$(mCurView & "", "#") &
". Values allowed are: " & Format$(acViewNormal, "#") & " = Normal, " &
Format$(acViewPreview, "#") & " = 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 = printerDevModeGet(mCurPrinterName)
6412 With myDevModeStruct
6413 .intCollate = mCurDevMode.intCollate
6414 .intColor = mCurDevMode.intColor
6415 .intCopies = mCurDevMode.intCopies
6416 .intDuplex = mCurDevMode.intDuplex
6417 .intOrientation = mCurDevMode.intOrientation
6418 .intPaperLength = mCurDevMode.intPaperLength
6419 .intPaperSize = mCurDevMode.intPaperSize
6430 .intPaperWidth = mCurDevMode.intPaperWidth
6431 .intPrintQuality = mCurDevMode.intPrintQuality
6432 .intScale = mCurDevMode.intScale
6433 .intTTOption = mCurDevMode.intTTOption
6434 .intYResolution = mCurDevMode.intYResolution
6435 .lngFields = mCurDevMode.lngFields
6436 End With
6437 myByteArray = devModeToBytes(myDevModeStruct)
6438 myReport.PrtDevMode = 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 = devNamesInfoBuildForPrinter(myPrinter)
6602 myReport.PrtDevNames = 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(mCurPrinterName)) = mPdfPrinterName
Then
6802 myGotPdf = True
6803 If Not pdfWriterInstalled() 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:\TEMP'."
6808 Else
6809 If dirExist(mCurPdfDir) = 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 = pdfFileNameCreate(mCurGetPdfFileNameFrom,
mCurReportFileNamePrefix, mCurReportFileNameSuffix, myReport)
6823 If mCurErrorCount = 0 Then
6824 If mCurShowPdfRegistryInfo = True Then
6825 myPdfRegistryInfo = String(40, "-") & vbCrLf & "Before
Setting Registry:" & vbCrLf & Space(15) & pdfRegistryGet()
6826 End If
6827 If pdfRegistrySet(myPdfFileName, mCurPdfDir) Then
6828 If mCurShowPdfRegistryInfo = True Then
6829 myPdfRegistryInfo = myPdfRegistryInfo & 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 mCurShowPdfRegistryInfo = True Then
6917 myPdfRegistryInfo = myPdfRegistryInfo & vbCrLf & String(40,
"-") & vbCrLf & "After Printing:" & Space(5) & pdfRegistryGet()
6918 MsgBox myPdfRegistryInfo, 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(theValue As rpCollate)
callStackPush mModuleName, "Collate"
On Error GoTo catchError

mCurDevMode.intCollate = theValue
mCurDevMode.lngFields = mCurDevMode.lngFields 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.intColor = theValue
mCurDevMode.lngFields = mCurDevMode.lngFields 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.intCopies = theValue
mCurDevMode.lngFields = mCurDevMode.lngFields Or rp_Copies

Xit:
callStackPop
On Error Resume Next
Exit Property

catchError:
errorLogWrite ""
Resume Xit
End Property
Public Property Let DefaultSource(theValue As rpDefaultSource)
callStackPush mModuleName, "DefaultSource"
On Error GoTo catchError

mCurDevMode.intDefaultSource = theValue
mCurDevMode.lngFields = mCurDevMode.lngFields Or rp_DefaultSource

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.intDuplex = theValue
mCurDevMode.lngFields = mCurDevMode.lngFields Or rp_Duplex

Xit:
callStackPop
On Error Resume Next
Exit Property

catchError:
errorLogWrite ""
Resume Xit
End Property
Public Property Let ErrorLogPath(ByVal theValue As String)
callStackPush mModuleName, "ErrorLogPath"
On Error GoTo catchError

mCurErrorLogPath = 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(theValue As Boolean)
callStackPush mModuleName, "LaunchAcrobat"
On Error GoTo catchError

mCurLaunchAcrobat = theValue

Xit:
callStackPop
On Error Resume Next
Exit Property

catchError:
errorLogWrite ""
Resume Xit
End Property
Public Property Let Orientation(theValue As rpOrientation)
callStackPush mModuleName, "Orientation"
On Error GoTo catchError

mCurDevMode.intOrientation = theValue
mCurDevMode.lngFields = mCurDevMode.lngFields Or rp_Orientation

Xit:
callStackPop
On Error Resume Next
Exit Property

catchError:
errorLogWrite ""
Resume Xit
End Property

'Public Property Let PaperLength(theValue As Integer)
' mCurDevMode.intPaperLength = theValue
' mCurDevMode.lngFields = mCurDevMode.lngFields Or rp_PaperLength
'End Property

Public Property Let PaperSize(theValue As rpPaperSize)
callStackPush mModuleName, "PaperSize"
On Error GoTo catchError

mCurDevMode.intPaperSize = theValue
mCurDevMode.lngFields = mCurDevMode.lngFields Or rp_PaperSize

Xit:
callStackPop
On Error Resume Next
Exit Property

catchError:
errorLogWrite ""
Resume Xit
End Property

'Public Property Let PaperWidth(theValue As Integer)
' mCurDevMode.intPaperWidth = theValue
' mCurDevMode.lngFields = mCurDevMode.lngFields Or rp_PaperWidth
'End Property

Public Property Let PrintQuality(theValue As rpPrintQuality)
callStackPush mModuleName, "PrintQuality"
On Error GoTo catchError

mCurDevMode.intPrintQuality = theValue
mCurDevMode.lngFields = mCurDevMode.lngFields Or rp_PrintQuality

Xit:
callStackPop
On Error Resume Next
Exit Property

catchError:
errorLogWrite ""
Resume Xit
End Property

'Public Property Let ScaleAmount(theValue As Integer)
' mCurDevMode.intScale = theValue
' mCurDevMode.lngFields = mCurDevMode.lngFields Or rp_Scale
'End Property

Public Property Let ShowPdfRegistryInfo(theValue As Boolean)
callStackPush mModuleName, "ShowPdfRegistryInfo"
On Error GoTo catchError

mCurShowPdfRegistryInfo = 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.intTTOption = theValue
' mCurDevMode.lngFields = mCurDevMode.lngFields 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(theValue As Integer)
callStackPush mModuleName, "YResolution"
On Error GoTo catchError

mCurDevMode.intYResolution = theValue
mCurDevMode.lngFields = mCurDevMode.lngFields Or rp_Y_Resolution

Xit:
callStackPop
On Error Resume Next
Exit Property

catchError:
errorLogWrite ""
Resume Xit
End Property
Public Function legalFileName(ByVal theName As String) As String
callStackPush mModuleName, "legalFileName"
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 pdfWriterInstalled() As Boolean
callStackPush mModuleName, "pdfWriterInstalled"
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(mPdfPrinterName, hPrinter, 0) Then
ClosePrinter (hPrinter)
pdfWriterInstalled = 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$(theDirPath, 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$(theDirPath, 2)) & " is unavailable."

Case Else
errorLogWrite "Unexpected case"
End Select

Resume Xit
End Function
Private Sub errorListAdd(ByVal 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(mCurErrorList) = 0 Then
mCurErrorList = "clsReportPrinter, version " & mVersionNumber & vbCrLf &
vbCrLf & mErrorListMessagePrefix & theMessage
Else
mCurErrorList = mCurErrorList & vbCrLf & mErrorListMessagePrefix &
theMessage
End If

Xit:
On Error Resume Next
Exit Sub

catchError:
MsgBox "clsReportPrinter: runtime error in errorListAdd()"
Resume Xit
End Sub
Private Function printerDevModeGet(ByVal thePrinterName As String) As
mPrtDevModeStruct
callStackPush mModuleName, "printerDevModeGet"
On Error GoTo catchError

' PURPOSE: To retrieve the PrtDevMode structure for the named printer
' ACCEPTS: Printer name (e.g. \\NTPRT41\INVHP5SI)
' RETURNS: Printer's DevMode structure

Dim myDevModeStruct As mPrtDevModeStruct
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(thePrinterName, hPrinter, 0) Then
If hPrinter > 0 Then
myDevModeLen = DocumentProperties(0, hPrinter, thePrinterName,
myDummyByte, myDummyByte, 0)
If myDevModeLen > 0 Then
ReDim myDevModeBytes(1 To myDevModeLen)
If DocumentProperties(0, hPrinter, thePrinterName, myDevModeBytes(1),
myDevModeBytes(1), myBufLen) > 0 Then
myDevModeStruct = bytesToDevMode(myDevModeBytes)
printerDevModeGet = myDevModeStruct
End If
End If
End If
Call ClosePrinter(hPrinter)
End If

Xit:
callStackPop
On Error Resume Next
Exit Function

catchError:
errorLogWrite ""
Resume Xit
End Function
Private Function bytesToDevMode(ByRef theByteArray() As Byte) As
mPrtDevModeStruct
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 mPrtDevModeStruct
Dim myDevModeString As mDevModeStringStruct

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 mPrtDevModeStruct) 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 mDevModeStringStruct

LSet myDevModeString = theDevMode
myByteArray = LeftB(myDevModeString.strDevMode, theDevMode.intSize +
theDevMode.intDriverExtra)
devModeToBytes = myByteArray

Xit:
callStackPop
On Error Resume Next
Exit Function

catchError:
errorLogWrite ""
Resume Xit
End Function
Private Function uniToAnsi(strUni 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 devNamesInfoBuildForPrinter(ByRef thePrinter As mPrinterStruct)
As Byte()
4000 callStackPush mModuleName, "devNamesInfoBuildForPrinter"
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 mDevNamesOffsetInfoStruct
Dim myOffsetString As mDevNamesOffsetStringStruct
Dim myDefaultPrinter As mPrinterStruct

Dim myBytes As Variant

' 4003 DoCmd.OpenReport ("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.DeviceName = Left$(thePrinter.DeviceName, adhcMaxDevice - 1)
4019 End If

' ---------------------------------------------
' The first offset is always offset 8

4020 With myDNOI
4021 .DriverOffset = adhcDevNamesFixed
4022 .DeviceOffset = .DriverOffset + Len(thePrinter.DriverName) + 1
4023 .OutputOffset = .DeviceOffset + Len(thePrinter.DeviceName) + 1
4024 .IsDefaultPrinter = thePrinter.IsDefaultPrinter
4029 End With

' ---------------------------------------------
' If all the information in thePrinter matches the current
' default printer, then set Default to be 1.

4030 myDefaultPrinter = printerDefaultGet
4031 With myDefaultPrinter
4032 If (.DeviceName = thePrinter.DeviceName) And (.DriverName =
thePrinter.DriverName) And .Port = thePrinter.Port Then
4033 myDNOI.IsDefaultPrinter = 1
4034 End If
4039 End With
' ---------------------------------------------

4041 LSet myOffsetString = myDNOI
4042 myBytes = myOffsetString.strDevInfo
4049 myBytes = myBytes & uniToAnsi(thePrinter.DriverName) & ChrB$(0) &
uniToAnsi(thePrinter.DeviceName) & ChrB$(0) & uniToAnsi(thePrinter.Port) &
ChrB$(0)

4999 devNamesInfoBuildForPrinter = 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,
mRegOptionNonVolatile, mRregKeyAllAccess, 0&, myKeyHandle, 0&)

If x <> 0 Then
theErrorMessage = "[ERROR: " & Str(x) & " returned by RegCreateKeyEx."
Else
Select Case theValueType
Case mRegSz
x = RegSetValueExString(myKeyHandle, theValueName, 0&, theValueType,
theValueData, Len(theValueData))
If x <> 0 Then
theErrorMessage = "[ERROR: " & Str(x) & " returned by
RegSetValueExString."
Else
regKeyValueSet = True
End If

Case mRegDWord
x = RegSetValueExLong(myKeyHandle, theValueName, 0&, theValueType,
theValueData, mRegDWord)
If x <> 0 Then
theErrorMessage = "[ERROR: " & Str(x) & " returned by
RegSetValueExLong."
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 thePdfFileNameRaw 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
..SpecificPrinter
' 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...we force LandScape if something besides
' portrait or landscape comes through

3002 Dim myOutputDir As String
Dim myPdfFileName As String
Dim myPdfFilePath As String

Dim myAcrobatPaperSize As String
Dim myAcrobatOrientation As String

Dim myValueName As String
Dim myValueData As String
Dim myErrorMessage As String

Const myDelim = ", "

3010 myValueName = "bExecViewer"
3011 If (mCurLaunchAcrobat <> 0) And (mCurLaunchAcrobat <> -1) Then
3012 errorListAdd ".LaunchAcrobat: Values allowed: True (i.e. -1) or
False (i.e. 0). Value passed = " & Format$(mCurLaunchAcrobat & "", "0#") & ".
"
3013 Else
3014 If mCurLaunchAcrobat = 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 mRegHKeyCurrentUser, mPdfWriterKeyName, myValueName,
myValueData, mRegSz, myErrorMessage
3029 End If

3160 myPdfFileName = legalFileName(thePdfFileNameRaw)
3170 myPdfFilePath = theOutputDir & "\" & myPdfFileName & ".pdf"

3200 Select Case mCurDevMode.intOrientation
Case rporient_Portrait
3211 myAcrobatOrientation = "1"

3220 Case rporient_landscape
3221 myAcrobatOrientation = "2"

3230 Case Else
3231 errorLogWrite "Unexpected case = " & Str(mCurDevMode.intOrientation)
& ". Invalid orientation should have been caught in
validatePrinterPropsAndCapabilities()."
3299 End Select

3300 Select Case mCurDevMode.intPaperSize
Case rpPaper_Letter
3319 myAcrobatPaperSize = "0"

3320 Case rpPaper_Legal
3329 myAcrobatPaperSize = "1"

3330 Case rpPaper_Tabloid
3339 myAcrobatPaperSize = "2"

3340 Case rpPaper_A4, rpPaper_A4_Small
3349 myAcrobatPaperSize = "3"

3350 Case rpPAPER_A3
3359 myAcrobatPaperSize = "4"

3360 Case rpPaper_Executive
3369 myAcrobatPaperSize = "5"

3370 Case rpPaper_B4
3379 myAcrobatPaperSize = "6"

3380 Case rpPaper_B5
3389 myAcrobatPaperSize = "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$(mCurDevMode.intPaperSize & "", "0#") & "."
3500 End Select
2599 pdfRegistrySet = True 'We don't want to
return False if the only problem is validation

3700 If (Len(myAcrobatOrientation) > 0) And (Len(myAcrobatPaperSize) > 0) Then
3701 pdfRegistrySet = False
3710 myValueName = "PDFFileName"
3711 myValueData = myPdfFilePath
3712 regKeyValueSet mRegHKeyCurrentUser, mPdfWriterKeyName, myValueName,
myValueData, mRegSz, myErrorMessage

3720 myValueName = "paper"
3721 myValueData = myAcrobatPaperSize
3722 regKeyValueSet mRegHKeyCurrentUser, mPdfWriterKeyName, myValueName,
myValueData, mRegSz, myErrorMessage

3730 myValueName = "orient"
3731 myValueData = myAcrobatOrientation
3732 regKeyValueSet mRegHKeyCurrentUser, mPdfWriterKeyName, myValueName,
myValueData, mRegSz, myErrorMessage

3740 myValueName = "bDocInfo"
3741 myValueData = "0"
3742 regKeyValueSet mRegHKeyCurrentUser, mPdfWriterKeyName, myValueName,
myValueData, mRegSz, myErrorMessage

3745 myValueName = "bEmbedAllFonts"
3746 myValueData = "0"
3747 regKeyValueSet mRegHKeyCurrentUser, mPdfWriterKeyName, myValueName,
myValueData, mRegSz, myErrorMessage

3750 pdfRegistrySet = True
3999 End If

Xit:
callStackPop
On Error Resume Next
Exit Function

catchError:
errorLogWrite "Raw PDF FileName = '" & thePdfFileNameRaw & ", 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:
' + gRegHKeyClassesRoot
' + gRegHKeyCurrentUser
' + gRegHKeyLocalMachine
' + gRegHKeyUsers
' - Name of the key to open
' - Name of the value to open. "vbNullString" 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(gRegHKeyLocalMachine,
"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(theRootKey, theKeyName, 0&, mRegKeyQueryValue,
myKeyHandle)
2040 If x <> 0 Then
2050 theReturnValue = "[ERROR " & Str(x) & " returned by RegOpenKeyEx]"
2060 Else
2070 x = RegQueryValueExA(myKeyHandle, theValueName, 0&, myValueType, 0&,
myDataLength)
2080 If x <> 0 Then
2090 If x = 2 Then
2100 theReturnValue = "[ERROR " & Str(x) & ": key not
found....Returned by RegQueryValueExA]"
2110 Else
2120 theReturnValue = "[ERROR " & Str(x) & " returned by
RegQueryValueExA]"
2130 End If
2140 Else
2141 If myDataLength > 0 Then
2150 Select Case myValueType
Case mRegSz: ' String
2170 myStringValue = String(myDataLength - 1, 0)
2180 x = RegQueryValueExString(myKeyHandle, theValueName, 0&,
myValueType, myStringValue, myDataLength)
2190 If x <> 0 Then
2200 theReturnValue = "[ERROR " & Str(x) & " returned by
RegQueryValueExString]"
2210 Else
2220 theReturnValue = Left$(myStringValue, myDataLength)
2230 regKeyValueGet = True
2240 End If

2250 Case mRegDWord: ' Long
x = RegQueryValueExLong(myKeyHandle, theValueName, 0&,
myValueType, myLongValue, myDataLength)
2260 If x <> 0 Then
2270 regKeyValueGet = "[ERROR " & Str(x) & " returned by
RegQueryValueExLong]"
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 = "PDFFileName"
Const myValueName3 = "TPDFFileName"

If regKeyValueGet(mRegHKeyCurrentUser, mPdfWriterKeyName, myValueName1,
myValue1) = False Then
myValue1 = "(key not found in registry)"
End If

If regKeyValueGet(mRegHKeyCurrentUser, mPdfWriterKeyName, myValueName2,
myValue2) = False Then
myValue2 = "(key not found in registry)"
End If

If regKeyValueGet(mRegHKeyCurrentUser, mPdfWriterKeyName, 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 printerArrayLoad()
callStackPush mModuleName, "printerArrayLoad"
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 myIniSectionArray() As String
Dim myIniDetailsArray1() As String
Dim myIniDetailsArray2() As String

Dim i As Integer
Dim k As Integer
Dim myParmCount As Integer
Dim myIniSection As String

myIniSection = iniSectionGet("Devices")

If Len(myIniSection) = 0 Then
myParmCount = 0
Else
myIniSectionArray = Split(myIniSection, vbNullChar)
ReDim aDevList(LBound(myIniSectionArray) To UBound(myIniSectionArray))
For i = LBound(myIniSectionArray) To UBound(myIniSectionArray)
If Len(myIniSectionArray(i)) > 0 Then
myIniDetailsArray1 = Split(myIniSectionArray(i), "=")
myIniDetailsArray2 = Split(myIniDetailsArray1(1), ",")
k = k + 1
ReDim Preserve mCurPrinters(k)
With mCurPrinters(k)
.DeviceName = myIniDetailsArray1(0)
.DriverName = myIniDetailsArray2(0)
.Port = myIniDetailsArray2(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(ByVal 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\INVHP5SI
' 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 subscriptOutOfRange = 9

7010 For i = 0 To UBound(mCurPrinters)
7020 With mCurPrinters(i)
7030 If .DeviceName = thePrinterName Then
7040 myPrinter.IsDefaultPrinter = .IsDefaultPrinter
7050 myPrinter.DeviceName = .DeviceName
7060 myPrinter.DriverName = .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 subscriptOutOfRange
'(do nothing, indicates that no printers are installed)
Case Else
errorLogWrite ""
End Select
Resume Xit
End Function
Private Function printerDefaultGet() As mPrinterStruct
callStackPush mModuleName, "printerDefaultGet"
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 = printerDefaultInfoGet()
If Len(strPrinter) > 0 Then
myDetailsArray = Split(strPrinter, ",")
With myPrinter
.DeviceName = myDetailsArray(0)
.DriverName = myDetailsArray(1)
.Port = myDetailsArray(2)
End With
End If

printerDefaultGet = myPrinter

Xit:
callStackPop
On Error Resume Next
Exit Function

catchError:
errorLogWrite ""
Resume Xit
End Function
Private Function printerDefaultInfoGet() As String
callStackPush mModuleName, "printerDefaultInfoGet"
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 = GetProfileString("Windows", "Device", noPrintersFound, myBuff,
myBuffLim - 1)

printerDefaultInfoGet = 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(ByVal theGroupRequested As String) As String
callStackPush mModuleName, "iniSectionGet"
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 = GetProfileSection(theGroupRequested, myBuff, myBuffLim - 1)

iniSectionGet = Left$(myBuff, myBuffLen)

Xit:
callStackPop
On Error Resume Next
Exit Function

catchError:
errorLogWrite ""
Resume Xit
End Function
Private Sub errorLogWrite(ByVal theSupplementalMessage 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) "noLocalError" 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_xit
1051 DoCmd.Echo True 'In case it was turned off
somewhere else

1060 If myErl = 0 Then
1061 mySource = mySource & ":" & mCallStack(mCallStackPointer)
1062 Else
1063 mySource = mySource & ":" & mCallStack(mCallStackPointer) & ": Line# " &
Str(myErl)
1069 End If
1070 mCurErrorCount = mCurErrorCount + 1
1079 myString = mErrorListMessagePrefix & "RUN-TIME ERROR @" & mySource & " --
Error# " & Format$(myNumber, "0000") & ": " & myDescription & " " &
theSupplementalMessage

1080 If Len(mCurErrorList) = 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(mCallStackPointer)
1420 If myErl > 0 Then
1430 Print #x, String(13, " ") & "Line " & Format$(myErl, "000000") & " " &
Format$(myNumber, "0000") & ": " & myDescription
1440 Else
1450 Print #x, String(13, " ") & Format$(myNumber, "0000") & ": " &
myDescription
1460 End If
1470 If theSupplementalMessage <> "" Then
1480 Print #x, Space$(19) & theSupplementalMessage
1490 End If

1500 Print #x, ""

1600 If mCallStackPointer > 1 Then
1610 For i = 0 To mCallStackLim
1620 If mCallStack(i) <> "" Then
1630 If i = mCallStackPointer 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_xit:
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 & ":" & "errorLogWrite, 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(mCallStackPointer) = ""
mCallStackPointer = mCallStackPointer - 1

If mCallStackPointer < 0 Then
mCallStackPointer = 0
End If

Exit Sub
End Sub
Private Sub callStackPush(ByVal theModuleName As String, ByVal theProcedureName
As String)

' PURPOSE: To add "theProcedureName" to the debug stack array

' NOTES: 1)If the programmer invokes this routine but neglects to invoke
"callStackPop"
' 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_err

Static overflowLogged As Boolean

mCallStackPointer = mCallStackPointer + 1
mCallStack(mCallStackPointer) = theModuleName & ":" & theProcedureName

callStackPush_xit:
Exit Sub

callStackPush_err:
If overflowLogged = False Then
errorLogWrite "Call Stack Overflow: Stack = " & Str(mCallStackPointer) & "
(Stack Limit = " & Str(mCallStackLim)
End If
overflowLogged = True
Resume callStackPush_xit
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(myBuffer, 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 theStringWithNulls 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, theStringWithNulls, Chr(0), vbTextCompare) Then
myString = Mid(theStringWithNulls, 1, InStr(theStringWithNulls, Chr(0)) -
1)
Else
myString = theStringWithNulls
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 defaultErrorLogName = "clsReportPrinter.ErrorLog.txt"

If Len(mCurErrorLogPath) = 0 Then
myAppDir = extractDirFromFullPath_elw(Application.CurrentDb.N ame)
errorLogPathGet = myAppDir & "\" & defaultErrorLogName
Else
errorLogPathGet = mCurErrorLogPath
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$(theFilePath) <> "")

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$(theFilePath,
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 validateErrorFilePath(ByVal theFilePath As String) As Boolean
5000 callStackPush mModuleName, "validateErrorFilePath"
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\sharename
' 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 badFileNameOrNumber = 52
Const pathFileAccessError = 75

5010 If (Mid$(theFilePath, 2, 1) = ":") Or (Left$(theFilePath, 2) = "\\") Then

On Error Resume Next
myReturnValue = Dir$(theFilePath)
On Error GoTo catchError

5020 If Len(myReturnValue) > 0 Then
5021 validateErrorFilePath = True
5029 Else
5030 x = FreeFile
5031 Open theFilePath For Append As x
5032 Close x
5033 Kill theFilePath
5039 validateErrorFilePath = 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, badFileNameOrNumber, pathFileAccessError
'(do nothing, these errors simply confirm that the path is bad)
Case Else
myString = "PROGRAM ERROR @" & mySource & " -- Error# " &
Format$(myNumber, "0000") & ": " & myDescription & "."
errorListAdd myString
End Select

Resume Xit
End Function
Private Function driverGetPointArray(ByVal theDeviceCapabilityType As
mDeviceCapabilityTypes, ByRef thePrinter As mPrinterStruct) As mXyPoint()
callStackPush mModuleName, "driverGetPointArray"
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 DeviceCapabilities() API call returns -1 upon failure

Dim myPointList() As mXyPoint
Dim myListCount As Long
Dim L As Long

myListCount = DeviceCapabilitiesLng(thePrinter.DeviceName, thePrinter.Port,
theDeviceCapabilityType, 0, 0)
If myListCount = -1 Then
errorLogWrite "Unable to retrieve device capability count for type" &
Str(theDeviceCapabilityType)
Else
If myListCount > 0 Then
ReDim myPointList(0 To myListCount - 1)
L = DeviceCapabilitiesAny(thePrinter.DeviceName, thePrinter.Port,
theDeviceCapabilityType, myPointList(0), 0)
If L = -1 Then
errorLogWrite "Unable to retrieve device capability list for type" &
Str(theDeviceCapabilityType)
End If
End If
End If

driverGetPointArray = myPointList

Xit:
callStackPop
On Error Resume Next
Exit Function

catchError:
errorLogWrite ""
Resume Xit
End Function
Private Sub validatePrinterPropsAndCapabilities(ByRef thePrinter As
mPrinterStruct)
callStackPush mModuleName, "validatePrinterPropsAndCapabilities"
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 mPrtDevModeStruct
Dim myPointArray() As mXyPoint
Dim myCurRez As mXyPoint
Dim myStringArray() As String
Dim myArraySize As Long
Dim capabilitySupported 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 = printerDevModeGet(thePrinter.DeviceName)

With mCurDevMode
' ---------------------------------------------
' Collate

Select Case .intCollate
Case rpCollate_False
'(do nothing)
Case rpCollate_True
If myPrinterDm.intCollate <> rpCollate_True Then
errorListAdd ".Collate: Collating requested, but printer " &
thePrinter.DeviceName & " does not support collating. Value specified = " &
Str(.intCollate) & ". "
End If
Case Else
errorListAdd ".Collate: Values allowed = " & Format$(rpCollate_True,
"#0") & " = True" & myDelim & Format$(rpCollate_False, "#0") & " = False.
Value specified = " & Str(.intCollate) & ". "
End Select

' ---------------------------------------------
' Color

Select Case .intColor
Case rpColor_Monochrome
'(do nothing)
Case rpColor_Color
If myPrinterDm.intColor <> rpColor_Color Then
errorListAdd ".Color: Color printing requested, but printer " &
thePrinter.DeviceName & " 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 = driverGetNumericValue(dcCopies, thePrinter)
If L < .intCopies Then
errorListAdd ".Copies: Max copies allowed by printer " &
thePrinter.DeviceName & " = " & Format$(L, "#0") & ". Value specified = " &
Format$(.intCopies, "#0") & "."
End If

' ---------------------------------------------
' DefaultSource NOT CHECKED AGAINST PRINTER CAPABILITIES

Select Case .intDefaultSource
Case rpSrc_Upper, rpSrc_OnlyOne, rpSrc_Lower, rpSrc_Middle,
rpSrc_Manual_Feed, rpSrc_Envelope, _
rpSrc_Envelope_Manual_Feed, rpSrc_Auto, rpSrc_Tractor,
rpSrc_Small_Format, rpSrc_Large_Format, _
rpSrc_Large_Capacity, rpSrc_Cassette, rpSrc_Form_Source, rpSrc_User
'(do nothing)
Case Else
errorListAdd ".DefaultSource: Values allowed = " & _
Format$(rpSrc_Upper, "#0") & " = Upper tray" & myDelim & _
Format$(rpSrc_OnlyOne, "#0") & " = Only Tray" & myDelim & _
Format$(rpSrc_Lower, "#0") & " = Lower Tray" & myDelim & _
Format$(rpSrc_Middle, "#0") & " = Middle Tray" & myDelim & _
Format$(rpSrc_Manual_Feed, "#0") & " = Manual Feed" & myDelim & _
Format$(rpSrc_Envelope, "#0") & " = Envelope (from tray)" & myDelim
& _
Format$(rpSrc_Envelope_Manual_Feed, "#0") & " = Envelope (manually
fed)" & myDelim & _
Format$(rpSrc_Auto, "#0") & " = Auto" & myDelim & _
Format$(rpSrc_Tractor, "#0") & " = Tractor" & myDelim & _
Format$(rpSrc_Small_Format, "#0") & " = Small-Format Tray" &
myDelim & _
Format$(rpSrc_Large_Format, "#0") & " = Large-Format Tray" &
myDelim & _
Format$(rpSrc_Large_Capacity, "#0") & " = Large-Capacity Tray" &
myDelim & _
Format$(rpSrc_Cassette, "#0") & " = Cassette" & myDelim & _
Format$(rpSrc_Form_Source, "#0") & " = Form Tray" & myDelim & _
Format$(rpSrc_User, "#0") & " = User-Specified." & _
" Value specified = " & Str(.intDefaultSource) & ". "
End Select

' ---------------------------------------------
' Duplex

If Not IsNull(.intDuplex) 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.intDuplex > 1) Then
errorListAdd ".Duplex: Duplex option requested, but " &
thePrinter.DeviceName & " 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_Portrait
'(do nothing)
Case rporient_landscape
L = driverGetNumericValue(dcOrientation, thePrinter)
If L = 0 Then
errorListAdd ".Orientation: Landscape requested, but " &
thePrinter.DeviceName & " does not support landscape orientation. Value
specified =" & Str(.intOrientation) & "."""
End If

Case Else
errorListAdd ".Orientation: Values allowed = " &
Format$(rporient_Portrait, "#0") & " = Portrait" & myDelim &
Format$(rporient_landscape, "#0") & " = Landscape. Value specified = " &
Str(.intOrientation) & ". "
End Select
' ---------------------------------------------
' PaperLength (NOT IMPLEMENTED)

' ---------------------------------------------
' PaperSize

Select Case .intPaperSize
Case rpSrc_Upper, rpSrc_OnlyOne, rpSrc_Lower, rpSrc_Middle,
rpSrc_Manual_Feed, rpSrc_Envelope, _
rpSrc_Envelope_Manual_Feed, rpSrc_Auto, rpSrc_Tractor,
rpSrc_Small_Format, rpSrc_Large_Format, _
rpSrc_Large_Capacity, rpSrc_Cassette, rpSrc_Form_Source, 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_German, "#0") & " =
German Std Fanfold 8 1/2 x 12" & myDelim
myMsg = myMsg & Format$(rpPaper_FanFold_Lgl_German, "#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_Postcard, "#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_Transverse, "#0") & " = A4
Transverse 210 x 297 mm" & myDelim
myMsg = myMsg & Format$(rpPaper_Letter_Extra_Transverse, "#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_Transverse, "#0") & " = A3
Extra Transverse 322 x 445 mm" & myDelim
myMsg = myMsg & Format$(rpPaper_User, "#0") & " = (user-defined)" &
myDelim
myMsg = myMsg & " Value specified = " & Str(.intPaperSize) & ". "
errorListAdd myMsg

End Select

' ---------------------------------------------
' PaperWidth (NOT IMPLEMENTED)

' ---------------------------------------------
' PrintQuality

If .intPrintQuality > 0 And (Not .intYResolution > 0) Then
errorListAdd ".PrintQuality: 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 .intPrintQuality
Case rpQual_Draft, rpQual_Low, rpQual_Medium, rpQual_High
'(do nothing, these are allowed values)
Case Else
errorListAdd ".PrintQuality: Allowed negative values are: -1 =
Draft, -2 = Low, -3 = Medium, -4 = High. Value specified = " &
Str(.intPrintQuality) & ". "
End Select
End If

' ---------------------------------------------
' ScaleAmount (NOT IMPLEMENTED)

' ---------------------------------------------
' TrueType Option (NOT IMPLEMENTED)

' ---------------------------------------------
' YResolution (in conjunction w/PrintQuality)

If .intYResolution > 0 And (Not .intPrintQuality > 0) Then
errorListAdd ".YResolution: If present, YResolution must be accompanied
by a positive value in .PrintQuality, which will function as the x-axis
resolution."
Else
If (.intYResolution > 0) And (.intPrintQuality > 0) Then
myCurRez.x = .intPrintQuality
myCurRez.Y = .intYResolution
myPointArray = driverGetPointArray(dcEnumResolutions, thePrinter)
myArraySize = UBound(myPointArray) - 1
capabilitySupported = False
For i = 0 To myArraySize
If (myPointArray(i).x = myCurRez.x) And (myPointArray(i).Y =
myCurRez.Y) Then
capabilitySupported = True
End If
Next i
If capabilitySupported = False Then
valuesFound = ""
For i = 0 To myArraySize
If Len(valuesFound) > 0 Then
valuesFound = valuesFound & ","
End If
valuesFound = valuesFound & Space(myIndent) &
Format$(myPointArray(i).x, "#0") & "x" & Format$(myPointArray(i).Y, "#0")
Next i
errorListAdd ".PrintQuality: Unsupported resolution. Resolutions
supported are " & valuesFound & ". Resolution specified = " &
Format$(myCurRez.x, "#0") & "x" & Format$(myCurRez.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 driverGetStringArray(theDeviceCapabilityType As
mDeviceCapabilityTypes, ByRef thePrinter As mPrinterStruct) As String()
callStackPush mModuleName, "driverGetStringArray"
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 DeviceCapabilities 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 theDeviceCapabilityType
Case dcPaperNames
myStringSize = mDriverStringLenPaperName
okToProceed = True
Case dcBinNames
myStringSize = mDriverStringLenBinName
okToProceed = True
Case dcFileDependencies
myStringSize = mDriverStringLenBinDependency
okToProceed = True
Case Else
errorLogWrite "Unexpected list type:" & Str(theDeviceCapabilityType)
End Select

If okToProceed = True Then
myListCount = DeviceCapabilitiesLng(thePrinter.DeviceName, thePrinter.Port,
theDeviceCapabilityType, 0, 0)
If myListCount = apiCallFailed Then
errorLogWrite "Unable to retrieve list count for " &
Str(theDeviceCapabilityType)
Else
If myListCount > 0 Then
ReDim myStringArray(0 To myListCount - 1)
myBuffer = String$(myStringSize * myListCount, 0)
L = DeviceCapabilitiesStr(thePrinter.DeviceName, thePrinter.Port,
theDeviceCapabilityType, myBuffer, 0)
If L = apiCallFailed Then
errorLogWrite "Unable to retrieve list for " &
Str(theDeviceCapabilityType)
Else
For i = 0 To myListCount - 1
myStringArray(i) = stripNulls(Mid$(myBuffer, i * myStringSize
+ 1, myStringSize))
Next i
End If
End If
End If

driverGetStringArray = myStringArray
End If
Xit:
callStackPop
On Error Resume Next
Exit Function

catchError:
errorLogWrite ""
Resume Xit
End Function
Private Function stripNulls(ByVal theOriginalString 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, theOriginalString, Chr(0), vbTextCompare) Then
theOriginalString = Mid(theOriginalString, 1, InStr(theOriginalString,
Chr(0)) - 1)
End If

stripNulls = theOriginalString

Xit:
debugStackPop
On Error Resume Next
Exit Function

catchError:
bugAlert True, ""
Resume Xit
End Function
Private Function driverGetNumericValue(ByVal theDeviceCapabilityType As
mDeviceCapabilityTypes, ByRef thePrinter As mPrinterStruct) As Long
callStackPush mModuleName, "driverGetNumericValue"
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 DeviceCapabilities() API call returns -1 upon failure

Dim L As Long

L = DeviceCapabilitiesLng(thePrinter.DeviceName, thePrinter.Port,
theDeviceCapabilityType, 0, 0)
If L = -1 Then
errorLogWrite "Unable to retrieve device capability value for " &
Str(theDeviceCapabilityType)
End If

driverGetNumericValue = L

Xit:
callStackPop
On Error Resume Next
Exit Function

catchError:
errorLogWrite ""
Resume Xit
End Function
Private Function driverGetIntegerArray(ByVal theDeviceCapabilityType As
mDeviceCapabilityTypes, ByRef thePrinter As mPrinterStruct) As Integer()
callStackPush mModuleName, "driverGetIntegerArray"
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 DeviceCapabilities() API call returns -1 upon failure

Dim myIntegerArray() As Integer

Dim myListCount As Long
Dim L As Long
myListCount = DeviceCapabilitiesLng(thePrinter.DeviceName, thePrinter.Port,
theDeviceCapabilityType, 0, 0)
If myListCount = -1 Then
errorLogWrite "Unable to retrieve list count for " &
Str(theDeviceCapabilityType)
Else
If myListCount > 0 Then
ReDim myIntegerArray(0 To myListCount - 1)
L = DeviceCapabilitiesAny(thePrinter.DeviceName, thePrinter.Port,
theDeviceCapabilityType, myIntegerArray(0), 0)
If L = -1 Then
errorLogWrite "Unable to retrieve list for " &
Str(theDeviceCapabilityType)
End If
End If
End If

driverGetIntegerArray = myIntegerArray

Xit:
callStackPop
On Error Resume Next
Exit Function

catchError:
errorLogWrite ""
Resume Xit
End Function
Private Function driverGetPointValue(ByVal theDeviceCapabilityType As
mDeviceCapabilityTypes, ByRef thePrinter As mPrinterStruct) As mXyPoint
callStackPush mModuleName, "driverGetPointValue"
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 DeviceCapabilities() API call returns -1 upon failure

Dim myPoint As mXyPoint
Dim L As Long

Dim myDoubleWord As mDoubleWordStruct
Dim mySplitWord As mSplitWordStruct
L = DeviceCapabilitiesLng(thePrinter.DeviceName, thePrinter.Port,
theDeviceCapabilityType, 0, 0)
If L = -1 Then
errorLogWrite "Unable to retrieve device capability for type" &
Str(theDeviceCapabilityType)
End If

myDoubleWord.Value = L
LSet mySplitWord = myDoubleWord

myPoint.x = mySplitWord.LoWord
myPoint.Y = mySplitWord.HiWord

driverGetPointValue = 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(theValue) 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 pdfFileNameCreate(ByVal theGetFileNameFrom As Long, ByVal
theFileNamePrefix As String, ByVal theFileNameSuffix As String, ByRef theReport
As Report) As String
callStackPush mModuleName, "pdfFileNameCreate"
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 theGetFileNameFrom
Case rpGetFromReportName
myPdfFileName = theFileNamePrefix & theReport.Name & theFileNameSuffix
Case rpGetFromReportCaption
With theReport
If Len(Trim$(.Caption & "")) > 0 Then
myPdfFileName = theFileNamePrefix & theReport.Caption &
theFileNameSuffix
Else
myPdfFileName = theFileNamePrefix & theReport.Name &
theFileNameSuffix
End If
End With
Case Else
errorListAdd ".GetPdfFileNameFrom: Values allowed: 1 = From Report Name,
2 = From Report's .Caption string. Value passed = " & Format$(theGetFileNameFrom
& "", "#") & ". "
End Select

pdfFileNameCreate = myPdfFileName

Xit:
callStackPop
On Error Resume Next
Exit Function

catchError:
errorLogWrite ""
Resume Xit
End Function
Private Function extractDirFromFullPath(theFullPath) As String
callStackPush mModuleName, "extractDirFromFullPath"
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

extractDirFromFullPath = Left$(theFullPath, L - 1)

Xit:
callStackPop
On Error Resume Next
Exit Function

catchError:
errorLogWrite ""
Resume Xit
End Function
Private Function extractDirFromFullPath_elw(theFullPath) 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

extractDirFromFullPath_elw = Left$(theFullPath, L - 1)

Xit:
callStackPop
On Error Resume Next
Exit Function

catchError:
MsgBox "clsReportPrinter: runtime error in extractDirFromFullPath_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
Nov 13 '05 #9

P: n/a
Thank you very much cyranoVR for youe reply.

I've implented your method, and it's working, thanks.

One minor thing though. Can we control the page size of the printed
reports? I have some reports that are set up to print on legal sized
paper or Landscape, but seems like all my reports are printed out using
Portrait.

For the reports that were set up as Landscape, they are ok, all I need
to do is to rotate the view (users might complaint), but the ones that
should print out to legal sized paper will not be acceptable.
Is there a solution to do?

thanks.

Nov 13 '05 #10

P: n/a
I actually have a similar annoyance: my one reports that needs to be on
legal-sized paper never "remembers" that it's legal sized. I always
have to set the printing preferences manually before printing. Yet
another report always wants to print to wrong printer on the other side
of the of the office, which is a shame because it's belongs in the
middle of a large set of reports.

However, since we now know that we can set the Default Printer
programmatically, a solution for both our problems would be as follows:
configure a second virtual PDF printer that prints Legal paper by
default (how to do this depends on the "Printing Preferences..." window
of your print driver). Then code your VBA so that our legal-sized
reports print to this printer:

net.SetDefault Printer "GS PDF Printer - Legal"
acc.DoCmd.OpenReport "rptSales_TwoYearHist" ' legal-paper

However, if you have 20 different reports, each of which is on its own
custom paper-size, things could get messy. On the other hand, if you're
really organized and keep all the report/printer/distribution
information in a local access table (as opposed to hard-coded in the
VBScript), you at least stand a chance of scaling to 100s of reports
and multiple virtual PDF printers.

Nov 13 '05 #11

P: n/a
Thank you cyranoVR.

I only have 2 reports that needed to be printed to legal sized paper.
Seems like Access remembers the report printing preferences while the
reports are printing from one server, however this changes when the
database is moved to another server. Since I only have 2 reports to
worrry about, I just manually set the printing preferences on the
reports and save it. It seems to be running ok.

Just want to say thank you. This is my first Google post, and It has
been a great one.

Nov 13 '05 #12

This discussion thread is closed

Replies have been disabled for this discussion.