Newsgroup: it.comp.appl.access
Titolo: Salvataggio PDF e invio e-mail.

Buonasera a tutti,
č possibile (senza modificare registri di Windows) salvare report in
formato PDF (magari con un nome che dipende da un dato nel record
sottostante) ed inviarlo, automaticamente (uso Lotus Notes) a un indirizzo
e-mail (fisso)?
Se servono maggiori deludidazioni, specificherň su richiesta.
Grazie,
DEL_REC
-- 
questo articolo e` stato inviato via web dal servizio gratuito 
http://www.newsland.it/news
 segnala gli abusi ad 
ab...@newsland.it


Cosa usi per creare il pdf?
Vedi se accetta il savesetting
In pratica l'iscrizione nella chiave di registro adatta del nome del file da
creare
MAssimiliano

 MAssimiliano
Uso il driver della Adobe Acrobat PDFWriter v.4.05.


free or not.
Assuming that all users have PdfWriter (couple hundred dollars per seat)
installed on their PC's, what you do is use the registry as your interface
to
Acrobat.   You set parms for file name and a couple other things and then
just
let it rip.
Here's some code that includes handling .PDF.   It's a class and is probably
wretched excess for what you want to do...but the code is there TB teased
out as
needed.   What's missing is the code to look at the user's printers and
figure
out whether PdfWriter is available.   I do that outside of the class BC I
use
the results to enable/disable the "PDF" button/option on the screen in
question.
If it looks promising, let me know and we'll figure out a way for me to
email it
as an attachment - since our respective email programs have probably made
hash
out of the line breaks...
============================================================================
====
VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "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.Name
)
    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
============================================================================
====
Trovato comp.databases.ms_access from PeteCresswell
ciao
MAssimiliano

[CUT]





[CUT]
Ciao MAssimiliano,
un bel po' di carne al fuoco, eh? Ma, a parer tuo, è possibile che si
debba utilizzare tutto questo codice e non si possa, invece, semplicemente
passare il nome con cui salvare il report in PDF ad Acrobat e, quindi,
effettuare l'invio via e-mail?
Ciao,


 DEL_REC
Ciao MAssimiliano,
ho risolto la questione della stampa in *.PDF, utilizzando un vecchio
consiglio del NG (3D: "Pdf For Vb Access 97" iniziato da Davide Spagnoli
il 18/02/2004 e, per quanto mi riguarda, con l'indicazione di Eugenio del
23/02/2004) e cambiando al volo la stampante di default prima e dopo
l'esecuzione del codice.
Una volta creato il file sul disco rigido è possibile automatizzarne anche
 l'invio?
Grazie,



 
Ciao,
anch'io uso pdfWriter e il massimo che sono riuscito ad ottenere e' la
finestra 'salva con nome' con gia' impostato il nome del file (da codice).
Se riesci ad ottenere di piu' fammelo sapere...Per quanto riguarda la
spedizione, si' e' possibile farla con Lotus Notes. Se ti occorre posso
darti un po' di codice da aggiustare un po'...
 
--------------------------------
Inviato via 
http://arianna.libero.it/usenet/

 darti un po' di codice da aggiustare un po'...
Ciao Van,
come dicevo a MAssimiliano, ho trovato aiuto nel 3D "Pdf For Vb Access 97"
iniziato da Davide Spagnoli il 18/02/2004. Con il codice postato sono
riuscito, adattandolo, a creare in modo del tutto trasparente un file
*.PDF con il nome che volevo io (dipendente di volta in volta dal valore
di un controllo). Prova con il codice che ti ho segnalato: mi sembra
perfetto (almeno per quanto serviva a me). Ecco il codice:
L'installazione avviene in due modi diversi a seconda se si tratta di
W9x/Me
o W2000/XP
In W9x/Me genera il file C:\Windows\System\PDFWritr.ini, in W2000/XP
utilizza il registro di configurazione del pc
HKEY_CURRENT_USER\Software\Adobe\Acrobat PDFWriter.
Quindi anche il codice VBA è diverso e ti riporto i due esempi.
Ho creato una maschera con pulsante Stampa che emette cinque volte il
report
"Fattura"
Ad ogni emissione esegue una pausa per consentire al sistema di rilasciare
il file PDFwritr.ini
**************
Windows 9x/Me
**************
Private Sub Stampa_Click()
On Error GoTo Err_Stampa_Click
Dim strTitolo As String, strFileName As String
Dim i As Integer, j As Integer
For i = 1 To 5
    Select Case i
        Case 1
            strTitolo = "Primo"
        Case 2
            strTitolo = "Secondo"
        Case 3
            strTitolo = "Terzo"
        Case 4
            strTitolo = "Quarto"
        Case 5
            strTitolo = "Quinto"
    End Select
    strFileName = "C:\" & strTitolo & ".PDF"
    SetPdfFileName (strFileName)
    DoCmd.OpenReport "report1", acViewNormal
    'Pausa per dar modo al sistema di rilasciare il file PDFwritr.ini
    For j = 0 To 5000
    DoEvents
    Next j
Next i
Exit_Stampa_Click:
    Exit Sub
Err_Stampa_Click:
    MsgBox ERR.Description
    Resume Exit_Stampa_Click
End Sub
'---------------------------------------------------------------------------
------------------------------
'Questa sub è consigliabile che venga inserita in un modulo
'deve essere copiata così com'è
'---------------------------------------------------------------------------
------------------------------
Public Sub SetPdfFileName(strFileName As String)
Dim lngFile As Long
On Error GoTo Err_SetPdfFileName
    lngFile = FreeFile
    Open "C:\Windows\System\PDFWritr.ini" For Output As #lngFile
    Print #lngFile, "[Acrobat PDFWriter]"
    Print #lngFile, "compatibility=1"
    Print #lngFile, "PDFFileName=""" & strFileName & """"
    Close #lngFile
Exit_SetPdfFileName:
    Exit Sub
Err_SetPdfFileName:
    MsgBox ERR.Description
    Resume Exit_SetPdfFileName
End Sub
*********
W2000/XP
*********
Private Sub Stampa_Click()
Dim strPathDoc As String
Dim strReport As String
Dim strFileName As String
Dim I As Integer
On Error GoTo Err_Stampa_Click
strPathDoc = "c:\"
strReport = "Fattura"
For I = 1 To 5
    Select Case I
        Case 1
            strFileName = "Primo.pdf"
        Case 2
            strFileName = "Secondo.pdf"
        Case 3
            strFileName = "Terzo.pdf"
        Case 4
            strFileName = "Quarto.pdf"
        Case 5
            strFileName = "Quinto.pdf"
    End Select
    Call SaveReportAsPDF(strReport, strPathDoc & strFileName)
Next I
Exit_Stampa_Click:
    Exit Sub
Err_Stampa_Click:
    MsgBox Err.Description
    Resume Exit_Stampa_Click
End Sub
'---------------------------------------------------------------------------
------------------------------
'Questa sub è consigliabile che venga inserita in un modulo
'deve essere copiata così com'è
'---------------------------------------------------------------------------
------------------------------
Option Compare Database
Option Explicit
 Public Const REG_SZ As Long = 1
   Public Const REG_DWORD As Long = 4
   Public Const HKEY_CLASSES_ROOT = &H80000000
   Public Const HKEY_CURRENT_USER = &H80000001
   Public Const HKEY_LOCAL_MACHINE = &H80000002
   Public Const HKEY_USERS = &H80000003
   Public Const ERROR_NONE = 0
   Public Const ERROR_BADDB = 1
   Public Const ERROR_BADKEY = 2
   Public Const ERROR_CANTOPEN = 3
   Public Const ERROR_CANTREAD = 4
   Public Const ERROR_CANTWRITE = 5
   Public Const ERROR_OUTOFMEMORY = 6
   Public Const ERROR_ARENA_TRASHED = 7
   Public Const ERROR_ACCESS_DENIED = 8
   Public Const ERROR_INVALID_PARAMETERS = 87
   Public Const ERROR_NO_MORE_ITEMS = 259
   Public Const KEY_QUERY_VALUE = &H1
   Public Const KEY_SET_VALUE = &H2
   Public Const KEY_ALL_ACCESS = &H3F
   Public Const REG_OPTION_NON_VOLATILE = 0
   Declare Function RegCloseKey Lib "advapi32.dll" _
   (ByVal hKey As Long) As Long
   Declare Function RegCreateKeyEx Lib "advapi32.dll" Alias _
   "RegCreateKeyExA" (ByVal hKey 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
   Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias _
   "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, _
   ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As _
   Long) As Long
   Declare Function RegQueryValueExString Lib "advapi32.dll" Alias _
   "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As _
   String, ByVal lpReserved As Long, lpType As Long, ByVal lpData _
   As String, lpcbData As Long) As Long
   Declare Function RegQueryValueExLong Lib "advapi32.dll" Alias _
   "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As _
   String, ByVal lpReserved As Long, lpType As Long, lpData As _
   Long, lpcbData As Long) As Long
   Declare Function RegQueryValueExNULL Lib "advapi32.dll" Alias _
   "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As _
   String, ByVal lpReserved As Long, lpType As Long, ByVal lpData _
   As Long, lpcbData As Long) As Long
   Declare Function RegSetValueExString Lib "advapi32.dll" Alias _
   "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, _
   ByVal Reserved As Long, ByVal dwType As Long, ByVal lpValue As _
   String, ByVal cbData As Long) As Long
   Declare Function RegSetValueExLong Lib "advapi32.dll" Alias _
   "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, _
   ByVal Reserved As Long, ByVal dwType As Long, lpValue As Long, _
   ByVal cbData As Long) As Long
'**********************************************************
Public Sub SaveReportAsPDF(strReportName As String, strPath As String)
    Dim strOldDefault As String
    strOldDefault = QueryKey("Software\Microsoft\Windows
NT\CurrentVersion\Windows",
"Device")
    SetKeyValue "Software\Microsoft\Windows NT\CurrentVersion\Windows",
"Device", "Acrobat PDFWriter", REG_SZ
    SetKeyValue "Software\Adobe\Acrobat PDFWriter", "PDFFilename", strPath,
REG_SZ
    SetKeyValue "Software\Adobe\Acrobat PDFWriter", "bExecViewer", 0,
REG_SZ
    DoCmd.OpenReport strReportName
    SetKeyValue "Software\Microsoft\Windows NT\CurrentVersion\Windows",
"Device", strOldDefault, REG_SZ
End Sub
   Public Function SetValueEx(ByVal hKey As Long, sValueName As String,
_
   lType As Long, vValue As Variant) As Long
       Dim lValue As Long
       Dim sValue As String
       Select Case lType
           Case REG_SZ
               sValue = vValue & Chr$(0)
               SetValueEx = RegSetValueExString(hKey, sValueName, 0&, _
                                              lType, sValue, Len(sValue))
           Case REG_DWORD
               lValue = vValue
               SetValueEx = RegSetValueExLong(hKey, sValueName, 0&, _
   lType, lValue, 4)
           End Select
   End Function
   Function QueryValueEx(ByVal lhKey As Long, ByVal szValueName As _
   String, vValue As Variant) As Long
       Dim cch As Long
       Dim lrc As Long
       Dim lType As Long
       Dim lValue As Long
       Dim sValue As String
       On Error GoTo QueryValueExError
       ' Determine the size and type of data to be read
       lrc = RegQueryValueExNULL(lhKey, szValueName, 0&, lType, 0&, cch)
       If lrc <> ERROR_NONE Then Error 5
       Select Case lType
           ' For strings
           Case REG_SZ:
               sValue = String(cch, 0)
   lrc = RegQueryValueExString(lhKey, szValueName, 0&, lType, _
   sValue, cch)
               If lrc = ERROR_NONE Then
                   vValue = Left$(sValue, cch - 1)
               Else
                   vValue = Empty
               End If
           ' For DWORDS
           Case REG_DWORD:
   lrc = RegQueryValueExLong(lhKey, szValueName, 0&, lType, _
   lValue, cch)
               If lrc = ERROR_NONE Then vValue = lValue
           Case Else
               'all other data types not supported
               lrc = -1
       End Select
QueryValueExExit:
       QueryValueEx = lrc
       Exit Function
QueryValueExError:
       Resume QueryValueExExit
   End Function
Public Function CreateNewKey(sNewKeyName As String, lPredefinedKey As Long)
    Dim hNewKey As Long         ' Handle to the new key
    Dim lRetVal As Long         ' Result of the RegCreateKeyEx function
    lRetVal = RegCreateKeyEx(lPredefinedKey, sNewKeyName, 0&, vbNullString,
REG_OPTION_NON_VOLATILE, _
        KEY_ALL_ACCESS, 0&, hNewKey, lRetVal)
    RegCloseKey (hNewKey)
End Function
Public Function SetKeyValue(sKeyName As String, sValueName As String,
vValueSetting
As Variant, lValueType As Long)
    Dim lRetVal As Long         ' Result of the SetValueEx function
    Dim hKey As Long            ' Handle of open key
    ' Open the specified key
    lRetVal = RegOpenKeyEx(HKEY_CURRENT_USER, sKeyName, 0, KEY_SET_VALUE,
hKey)
    lRetVal = SetValueEx(hKey, sValueName, lValueType, vValueSetting)
    RegCloseKey (hKey)
End Function
Public Function QueryKey(sKeyName As String, sValueName As String)
    Dim lRetVal As Long         ' Result of the API functions
    Dim hKey As Long            ' Handle of opened key
    Dim vValue As Variant       ' Setting of queried value
    lRetVal = RegOpenKeyEx(HKEY_CURRENT_USER, sKeyName, 0, KEY_QUERY_VALUE,
hKey)
    lRetVal = QueryValueEx(hKey, sValueName, vValue)
    QueryKey = vValue
    RegCloseKey (hKey)
End Function
Se, cortesemetne, mi fai avere qualche dritta per la spedizione von Lotus
del file creato, ti sarei enormemente riconoscente.
Grazie,


 DEL_REC
In un post successivo al tuo, ho provato a dare qualche dritta, vedi se
riesci a fare qualcosa. Prometto che domani provo ad implementare una
spedizione LN su Access e la rendo disponibile. Stasera sono troppo fuso....
Ciao e grazie della risposta
Togli XXX dall'indirizzo e-mail, se vuoi scrivermi


 Togli XXX dall'indirizzo e-mail, se vuoi scrivermi
Penso tu faccia riferimento al 3D di TANNHAUSER, vero?
Ora lo leggo.
