Print Select Dialog Form -- Part 2

Attribute VB_Name = "mdlPrinterAccess"
'----------------------------------------------------------------------------------------
' Module    : mdlPrinterAccess
' Date      : 18 May 2003
' Author    : Cassandra Roads, P. Eng.
' Copyright (c) 2003 Professional Logics Corporation
'----------------------------------------------------------------------------------------
'
Option Explicit

'
'----------------------------------------------------------------------------------------
'   API DECLARATIONS
'----------------------------------------------------------------------------------------
'
Public Const CCHDEVICENAME = 32
Public Const CCHFORMNAME = 32
Public Const DC_BINNAMES = 12
Public Const DC_BINS = 6
Public Const DC_PAPERNAMES = 16
Public Const DC_PAPERS = 2
Public Const DC_PAPERSIZE = 3
'
Public Const DM_COLLATE As Long = &H8000
Public Const DM_COLOR = &H800&
Public Const DM_COPIES = &H100&
Public Const DM_COPY = 2
Public Const DM_DEFAULTSOURCE = &H200&
Public Const DM_MODIFY = 8
Public Const DM_ORIENTATION = &H1&
Public Const DM_PAPERLENGTH = &H4&
Public Const DM_PAPERSIZE = &H2&
Public Const DM_PAPERWIDTH = &H8&
Public Const DM_PRINTQUALITY = &H400&
Public Const DM_SCALE = &H10&
Public Const DM_UPDATE = 1
Public Const DM_IN_BUFFER = DM_MODIFY
Public Const DM_OUT_BUFFER = DM_COPY
Public Const DM_OUT_DEFAULT = DM_UPDATE
'
Public Enum Printer_Status
    PRINTER_STATUS_PAUSED = &H1
    PRINTER_STATUS_ERROR = &H2
    PRINTER_STATUS_PENDING_DELETION = &H4
    PRINTER_STATUS_PAPER_JAM = &H8
    PRINTER_STATUS_PAPER_OUT = &H10
    PRINTER_STATUS_MANUAL_FEED = &H20
    PRINTER_STATUS_PAPER_PROBLEM = &H40
    PRINTER_STATUS_OFFLINE = &H80
    PRINTER_STATUS_IO_ACTIVE = &H100
    PRINTER_STATUS_BUSY = &H200
    PRINTER_STATUS_PRINTING = &H400
    PRINTER_STATUS_OUTPUT_BIN_FULL = &H800
    PRINTER_STATUS_NOT_AVAILABLE = &H1000
    PRINTER_STATUS_WAITING = &H2000
    PRINTER_STATUS_PROCESSING = &H4000
    PRINTER_STATUS_INITIALIZING = &H8000
    PRINTER_STATUS_WARMING_UP = &H10000
    PRINTER_STATUS_TONER_LOW = &H20000
    PRINTER_STATUS_NO_TONER = &H40000
    PRINTER_STATUS_PAGE_PUNT = &H80000
    PRINTER_STATUS_USER_INTERVENTION = &H100000
    PRINTER_STATUS_OUT_OF_MEMORY = &H200000
    PRINTER_STATUS_DOOR_OPEN = &H400000
End Enum
'
Public Const STANDARD_RIGHTS_REQUIRED = &HF0000
Public Const PRINTER_ACCESS_USE = &H8
Public Const PRINTER_NORMAL_ACCESS = (STANDARD_RIGHTS_REQUIRED Or PRINTER_ACCESS_USE)
'
Public Type ACL
        AclRevision As Byte
        Sbz1 As Byte
        AclSize As Integer
        AceCount As Integer
        Sbz2 As Integer
End Type
'
Public Type SECURITY_DESCRIPTOR
        Revision As Byte
        Sbz1 As Byte
        Control As Long
        Owner As Long
        Group As Long
        Sacl As ACL
        Dacl As ACL
End Type
'
Private Type DEVMODE
    dmDeviceName As String * CCHDEVICENAME
    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 * CCHFORMNAME
    dmUnusedPadding As Integer
    dmBitsPerPel As Long
    dmPelsWidth As Long
    dmPelsHeight As Long
    dmDisplayFlags As Long
    dmDisplayFrequency As Long
End Type
'
Private Type PRINTER_DEFAULTS
    pDatatype As String
    pDevMode As DEVMODE
    DesiredAccess As Long
End Type
'
Public Type PRINTER_INFO_2
        pServerName As Long
        pPrinterName As Long
        pShareName As Long
        pPortName As Long
        pDriverName As Long
        pComment As Long
        pLocation As Long
        pDevMode As Long
        pSepFile As Long
        pPrintProcessor As Long
        pDatatype As Long
        pParameters As Long
        pSecurityDescriptor As Long
        Attributes As Long
        Priority As Long
        DefaultPriority As Long
        StartTime As Long
        UntilTime As Long
        Status As Long
        cJobs As Long
        AveragePPM As Long
End Type
'
Public Type POINTAPI
    X As Long
    Y As Long
End Type
'
Private Declare Function DeviceCapabilities Lib "winspool.drv" _
    Alias "DeviceCapabilitiesA" ( _
    ByVal lpsDeviceName As String, _
    ByVal lpPort As String, _
    ByVal iIndex As Long, _
        lpOutput As Any, _
    ByVal lpDevMode As Long _
    ) As Long
'
Public Declare Function ClosePrinter Lib "winspool.drv" _
    (ByVal hPrinter As Long) As Long
'
Public Declare Function DocumentProperties Lib "winspool.drv" _
    Alias "DocumentPropertiesA" ( _
    ByVal hwnd As Long, _
    ByVal hPrinter As Long, _
    ByVal pDeviceName As String, _
    ByVal pDevModeOutput As Long, _
    ByVal pDevModeInput As Long, _
    ByVal fMode As Long _
    ) As Long
'
Public 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
'
Public Declare Function OpenPrinter Lib "winspool.drv" _
    Alias "OpenPrinterA" ( _
    ByVal pPrinterName As String, _
    phPrinter As Long, _
    pDefault As PRINTER_DEFAULTS _
    ) As Long
'
Public Declare Function IsBadStringPtrLng Lib "kernel32" _
    Alias "IsBadStringPtrA" ( _
    ByVal lpsz As Long, _
    ByVal ucchMax As Long _
    ) As Long
'
Public Declare Function SetPrinter Lib "winspool.drv" _
    Alias "SetPrinterA" ( _
    ByVal hPrinter As Long, _
    ByVal Level As Long, _
    pPrinter As Byte, _
    ByVal Command As Long _
    ) As Long
'
Public Declare Sub CopyMemory Lib "kernel32" _
    Alias "RtlMoveMemory" ( _
    Destination As Any, _
    Source As Any, _
    ByVal Length As Long)
'

'
'----------------------------------------------------------------------------------------
'   PRINTER ACCESS FUNCTIONS/SUBS
'----------------------------------------------------------------------------------------
'
'----------------------------------------------------------------------------------------
' Procedure : GetPaperSizes
' Date      : 18 May 2003
' Author    : Cassandra Roads, P. Eng.
' Copyright (c) 2003 Professional Logics Corporation
'----------------------------------------------------------------------------------------
'
Public Function GetPaperSizes(ByVal strPrinterName As String, _
        ByRef strPaperSizes() As String, ByRef intPaperSizesIndices() As Integer, _
        ByRef apiPaperSizes() As POINTAPI, ByRef intDefaultPaperSize As Integer, _
        ByRef strPaperBinNames() As String, ByRef intPaperBinNumbers() As Integer, _
        ByRef intDefaultBin As Integer) As Boolean
    '
    '   Get the name and port of the default printer, which are needed by the
    '               DeviceCapabilities API calls.
    '   Get the count of PaperBin names supported by printer.
    '   Re-dimension the arrays to receive all the PaperSize values.
    '   Get a list of PaperSize indices supported by the printer
    '   Get a string buffer of PaperSize names supported by the printer.
    '   Split the PaperSize names into the array that was passed in.
    '   Get a list of paper widths and heights.  The data is stored in a POINTAPI
    '               structure.
    '   Get the number of PaperBins.
    '   Re-dimension the arrays to receive all of the PaperBin values.
    '   Get the PaperBin numbers from the printer driver.
    '   Get the PaperBin names from the printer driver.
    '   Split the PaperBin names into the array that was passed in.
    '   Return the default values for the PaperSize and the PaperBin lists.
    '   Exit.
    '------------------------------------------------------------------------------------
    '
    Dim prtPrinter As Printer, I As Integer, J As Integer, strTemp As String
    Dim strDeviceName As String, strDevicePort As String
    Dim lngPaperSizeCount As Long, strPaperNameList As String
    Dim lngBins As Long, strBinNames As String
    Dim udtPrinterDevMode As DEVMODE

    For Each prtPrinter In Printers
        If prtPrinter.DeviceName = strPrinterName Then Exit For
    Next prtPrinter
    '
    On Error GoTo GetPaperSizes_Error
    '
    '   Get the name and port of the default printer, which are needed by the
    '   DeviceCapabilities API calls.
    '
    strDeviceName = prtPrinter.DeviceName
    strDevicePort = prtPrinter.Port
    '
    '--------------------------------------------------
    '   Get the count of PaperBin names supported by printer.
    '
    lngPaperSizeCount = DeviceCapabilities(strDeviceName, strDevicePort, DC_PAPERNAMES, _
        ByVal vbNullString, 0)
    '
    '   Re-dimension the arrays to receive all the PaperSize values.
    '
    ReDim strPaperSizes(1 To lngPaperSizeCount)
    ReDim intPaperSizesIndices(1 To lngPaperSizeCount)
    ReDim apiPaperSizes(1 To lngPaperSizeCount)
    '
    '   Get a list of PaperSize indices supported by the printer
    '
    lngPaperSizeCount = DeviceCapabilities(strDeviceName, strDevicePort, DC_PAPERS, _
        intPaperSizesIndices(1), 0)
    '
    '   Get a string buffer of PaperSize names supported by the printer.
    '
    strPaperNameList = String(lngPaperSizeCount * 64, 0)
    lngPaperSizeCount = DeviceCapabilities(strDeviceName, strDevicePort, DC_PAPERNAMES, _
        ByVal strPaperNameList, 0)
    '
    '   Split the PaperSize names into the array that was passed in.
    '
    For I = 1 To lngPaperSizeCount
        strTemp = Mid(strPaperNameList, ((I - 1) * 64 + 1), 64)
        J = InStr(1, strTemp, Chr(0))
        strPaperSizes(I) = Left(strTemp, J - 1)
    Next I
    '
    '   Get a list of paper widths and heights.  The data is stored in a POINTAPI
    '               structure.
    '
    lngPaperSizeCount = DeviceCapabilities(strDeviceName, strDevicePort, DC_PAPERSIZE, _
        apiPaperSizes(1), 0)
    '
    '--------------------------------------------------
    '   Get the number of PaperBins.
    '
    lngBins = DeviceCapabilities(strDeviceName, strDevicePort, DC_BINS, _
        ByVal vbNullString, 0)
    '
    '   Re-dimension the arrays to receive all of the PaperBin values.
    '
    ReDim intPaperBinNumbers(1 To lngBins)
    ReDim strPaperBinNames(1 To lngBins)
    '
    '   Get the PaperBin numbers from the printer driver.
    '
    lngBins = DeviceCapabilities(strDeviceName, strDevicePort, DC_BINS, _
        intPaperBinNumbers(1), 0)
    '
    '   Get the PaperBin names from the printer driver.
    '
    strBinNames = String(24 * lngBins, Chr(0))
    lngBins = DeviceCapabilities(strDeviceName, strDevicePort, DC_BINNAMES, _
        ByVal strBinNames, 0)
    '
    '   Split the PaperBin names into the array that was passed in.
    '
    For I = 1 To lngBins
        strTemp = Mid(strBinNames, ((I - 1) * 24 + 1), 24)
        J = InStr(1, strTemp, Chr(0))
        strPaperBinNames(I) = Left(strTemp, J - 1)
    Next I
    '
    '   Return the default values for the PaperSize and the PaperBin lists.
    '
    intDefaultPaperSize = GetPrinterProperty(strDeviceName, DM_PAPERSIZE)
    intDefaultBin = GetPrinterProperty(strDeviceName, DM_DEFAULTSOURCE)
    '
    '   Exit
    '
    GetPaperSizes = False
    On Error GoTo 0
    Exit Function
    
GetPaperSizes_Error:
    Debug.Print "mdlPrinterAccess : GetPaperSizes :: " & Err.Number & " : " & _
            Err.Description
    Err.Clear
    On Error GoTo 0
    GetPaperSizes = True
End Function
'
'----------------------------------------------------------------------------------------
'

'----------------------------------------------------------------------------------------
' Procedure : GetPrinterProperty
' Date      : 18 May 2003
' Author    : Cassandra Roads, P. Eng.
' Copyright (c) 2003 Professional Logics Corporation
'----------------------------------------------------------------------------------------
'
Public Function GetPrinterProperty(ByVal strPrinterName As String, _
            ByVal lngPropertyType As Long) As Integer

    '   Code adapted from Microsoft KB article Q230743.

    Dim hPrinter As Long
    Dim udtPD As PRINTER_DEFAULTS
    Dim udtDM As DEVMODE
    Dim lngRet As Long
    Dim bytDevModeData() As Byte
    Dim lngPrinterStatus As Long

    On Error GoTo GetPrinterProperty_Error
    '
    GetPrinterProperty = 0
    '
    udtPD.DesiredAccess = PRINTER_NORMAL_ACCESS
    '
    '   Get the printer handle.
    '
    lngRet = OpenPrinter(strPrinterName, hPrinter, udtPD)
    '   Couldn't access the printer
    If (lngRet = 0) Or (hPrinter = 0) Then Exit Function
    '
    '   Find out how many bytes needed for the printer properties.
    '
    lngRet = DocumentProperties(0, hPrinter, strPrinterName, 0, 0, 0)
    '
    If (lngRet >= 0) Then
        '
        '   Make sure the byte array is large enough, including the
        '   128 bytes extra in case the printer driver is lieing.
        '
        ReDim bytDevModeData(0 To lngRet + 128)
        '
        '   Load the printer properties into the byte array.
        '
        lngRet = DocumentProperties(0, hPrinter, strPrinterName, _
                VarPtr(bytDevModeData(0)), 0, DM_OUT_BUFFER)
        '
        If (lngRet >= 0) Then
            '
            '   Copy the byte array to the DEVMODE structure.
            '
            Call CopyMemory(udtDM, bytDevModeData(0), Len(udtDM))
            '
            If udtDM.dmFields Or (lngPropertyType <> 0) Then
                '
                '   Get the value of the requested property.
                '
                Select Case lngPropertyType
                    Case DM_COLLATE
                        GetPrinterProperty = udtDM.dmCollate
                    Case DM_COLOR
                        GetPrinterProperty = udtDM.dmColor
                    Case DM_COPIES
                        GetPrinterProperty = udtDM.dmCopies
                    Case DM_DEFAULTSOURCE
                        GetPrinterProperty = udtDM.dmDefaultSource
                    Case DM_ORIENTATION
                        GetPrinterProperty = udtDM.dmOrientation
                    Case DM_PAPERLENGTH
                        GetPrinterProperty = udtDM.dmPaperLength
                    Case DM_PAPERSIZE
                        GetPrinterProperty = udtDM.dmPaperSize
                    Case DM_PAPERWIDTH
                        GetPrinterProperty = udtDM.dmPaperWidth
                    Case DM_PRINTQUALITY
                        GetPrinterProperty = udtDM.dmPrintQuality
                    Case DM_SCALE
                        GetPrinterProperty = udtDM.dmScale
                End Select
            End If
        End If
    End If
    '
    '   Release the printer handle.
    '
    If (hPrinter <> 0) Then Call ClosePrinter(hPrinter)
    '
    Exit Function
            
GetPrinterProperty_Error:
    Debug.Print "mdlPrinterAccess : GetPrinterProperty :: " & Err.Number & " : " & _
            Err.Description
    Err.Clear
    On Error GoTo 0
    GetPrinterProperty = 0
    If (hPrinter <> 0) Then Call ClosePrinter(hPrinter)
End Function
'
'----------------------------------------------------------------------------------------
'