Option Compare Database
Option Explicit
'@~~~~~~~ NT Security Constants ~~~~~~~~@
Private Const STANDARD_RIGHTS_REQUIRED = &HF0000
Private Const PRINTER_ACCESS_ADMINISTER = &H4
Private Const PRINTER_ACCESS_USE = &H8
Private Const PRINTER_ALL_ACCESS = _
(STANDARD_RIGHTS_REQUIRED Or PRINTER_ACCESS_ADMINISTER _
Or PRINTER_ACCESS_USE)
'@~~~~~~~ DEVMODE Constants ~~~~~~~~@
Private Const DM_MODIFY = 8
Private Const DM_IN_BUFFER = DM_MODIFY
Private Const DM_COPY = 2
Private Const DM_OUT_BUFFER = DM_COPY
Private Const DM_FORMNAME As Long = &H10000
Private Const DM_ORIENTATION = &H1&
Private Const DM_PAPERSIZE = &H2
Private Const DM_PAPERLENGTH = &H4
Private Const DM_PAPERWIDTH = &H8
Private Const DMORIENT_LANDSCAPE = 2
Private Const DMORIENT_PORTRAIT = 1
'@~~~~~~~~~~~ DEVMODE ~~~~~~~~~~~@
' I have removed all of the NT only and
' Windows 9X (2000 as well) only elements
Private Type DEVMODE
dmDeviceName As String * 32
dmSpecVersion As Integer
dmDriverVersion As Integer
dmSize As Integer
dmDriverExtra As Integer
dmFields As Long
dmOrientation As Integer
dmPaperSize As Integer
dmPaperLength As Integer
dmPaperWidth As Integer
dmScale As Integer
dmCopies As Integer
dmDefaultSource As Integer
dmPrintQuality As Integer
dmColor As Integer
dmDuplex As Integer
dmYResolution As Integer
dmTTOption As Integer
dmCollate As Integer
dmFormName As String * 32
dmLogPixels As Integer
dmBitsPerPel As Long
dmPelsWidth As Long
dmPelsHeight As Long
dmDisplayFlags As Long
dmDisplayFrequency As Long
End Type
Type str_DEVMODE
RGB As String * 94
End Type
Private Type PRINTER_DEFAULTS
pDatatype As String
pDevMode As Long
DesiredAccess As Long
End Type
Private Declare Function OpenPrinter Lib _
"winspool.drv" Alias "OpenPrinterA" _
(ByVal pPrinterName As String, phPrinter As Long, _
pDefault As PRINTER_DEFAULTS) As Long
Private Declare Function SetPrinter Lib _
"winspool.drv" Alias "SetPrinterA" _
(ByVal hPrinter As Long, ByVal Level As Long, _
pPrinter As Any, ByVal Command As Long) As Long
Private Declare Function GetPrinter Lib _
"winspool.drv" Alias "GetPrinterA" _
(ByVal hPrinter As Long, ByVal Level As Long, _
pPrinter As Any, ByVal cbBuf As Long, _
pcbNeeded 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 Sub CopyMemory Lib "kernel32" _
Alias "RtlMoveMemory" (hpvDest As Any, _
hpvSource As Any, ByVal cbCopy As Long)
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, ByVal _
pDevModeOutput As Any, ByVal pDevModeInput As Any, _
ByVal fMode As Long) As Long
Public Function SetPaperSizeOrientation(intPaperSize As Integer, _
intPaperWidth As Integer, intPaperLength As Integer, _
intOrientation As Integer)
Dim udtPD As PRINTER_DEFAULTS
Dim DevString As str_DEVMODE
Dim udtDEVMODE As DEVMODE
Dim strDevModeExtra As String
Dim lngBuffer() As Long
Dim lngPrnHndle As Long
Dim lngRetVal As Long
Dim lngDMpntr As Long
Dim lngRet As Long
Dim strPrintName As String
udtPD.pDatatype = vbNullString
udtPD.pDevMode = 0&
'The next call is NT security, it
'Has no adverse affect on Windows 9X or 2000
udtPD.DesiredAccess = PRINTER_ALL_ACCESS
strPrintName = GetDefaultPrinter
lngRet = OpenPrinter(strPrintName, lngPrnHndle, udtPD)
lngRet = GetPrinter(lngPrnHndle, 2, ByVal 0&, 0, lngRetVal)
ReDim lngBuffer((lngRetVal \ 4))
lngRet = GetPrinter(lngPrnHndle, 2, lngBuffer(0), _
lngRetVal, lngRetVal)
'The pointer (7th element of the array) to the DEVMODE
lngDMpntr = lngBuffer(7)
'Public to Private and vice-versa
Call CopyMemory(udtDEVMODE, ByVal lngDMpntr, Len(udtDEVMODE))
'Mark the bit and Change the orientation
udtDEVMODE.dmFields = udtDEVMODE.dmFields Or _
DM_ORIENTATION Or DM_PAPERSIZE _
Or DM_PAPERLENGTH Or DM_PAPERWIDTH _
And Not DM_FORMNAME
udtDEVMODE.dmOrientation = intOrientation
udtDEVMODE.dmPaperSize = intPaperSize
udtDEVMODE.dmPaperLength = intPaperLength
udtDEVMODE.dmPaperWidth = intPaperWidth
Call CopyMemory(ByVal lngDMpntr, udtDEVMODE, Len(udtDEVMODE))
lngRet = DocumentProperties(Access.Application.hWndAccessApp, _
lngPrnHndle, strPrintName, ByVal lngDMpntr, _
ByVal lngDMpntr, DM_IN_BUFFER Or DM_OUT_BUFFER)
'The Magic happens right here!
lngRet = SetPrinter(lngPrnHndle, 2, lngBuffer(0), 0&)
'All done
Call ClosePrinter(lngPrnHndle)
End Function
Private Function GetDefaultPrinter() As String
Dim strDefault As String
Dim lngbuf As Long
strDefault = String(255, Chr(0))
lngbuf = GetProfileString("Windows", "Device", "", strDefault, Len(strDefault))
If lngbuf > 0 Then
GetDefaultPrinter = fstrDField(strDefault, ",", 1)
Else
GetDefaultPrinter = ""
End If
End Function
Private Function fstrDField(mytext As String, delim As String, groupnum As Integer) As String
' this is a standard delimiter routine that every developer I know has.
' This routine has a million uses. This routine is great for splitting up
' data fields, or sending multiple parms to a openargs of a form
'
' Parms are
' mytext - a delimited string
' delim - our delimiter (usually a , or / or a space)
' groupnum - which of the delimited values to return
'
Dim startpos As Integer, endpos As Integer
Dim groupptr As Integer, chptr As Integer
chptr = 1
startpos = 0
For groupptr = 1 To groupnum - 1
chptr = InStr(chptr, mytext, delim)
If chptr = 0 Then
fstrDField = ""
Exit Function
Else
chptr = chptr + 1
End If
Next groupptr
startpos = chptr
endpos = InStr(startpos + 1, mytext, delim)
If endpos = 0 Then
endpos = Len(mytext) + 1
End If
fstrDField = Mid$(mytext, startpos, endpos - startpos)
End Function
