'VERSION 1.0 CLASS
'BEGIN
'  MultiUse = -1  'True
'End
'Copyright © 1998-2002  Version 1.4d
'
'ALL functions and code are copyrighted by:
'ATTAC Consulting Group
'2869 Baylis Ann Arbor, MI  48108  USA
'mailto: 75323.2112@compuserve.com
'-----------------------------------------------------------------------------------------------------------------
'IMPORTANT LEGAL NOTICE REGARDING YOUR LICENSE AND USE OF THE SOFTWARE
'
'This code is protected by copyright law and international treaties and is
'provided under specific license.
'
'End User has no right to copy, reproduce or otherwise distribute or modify this code.
'
'ATTAC Consulting Group provides no explict or implicit warrenties for use of the software.
'User accepts all responsiblity for any consequenses, damages, real or otherwise from use
'of the software.
'------------------------------------------------------------------------------------------------------------------
Option Explicit
Option Compare Database

Private Type udtDevModeAnsi
    dmDeviceName As String * 16
    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 * 16
    dmLogPixels As Long
    dmBitsPerPel As Long
    dmPelsWidth As Long
    dmPelsHeight As Long
    dmDisplayFlags As Long
    dmDisplayFrequency As Long
End Type

Private Type udtDevModeStr
    RGB As String * 2048
End Type

Private Type udtDevModeStrShort
    RGB As String * 94
End Type
Private Type PINFO1
    dwFlags As Long
    dwDescription As Long
    dwName As Long
    dwComment As Long
End Type
Private Type PInfo1Full
    dwFlags As Long
    lpstrDescription As String
    lpstrName As String
    lpstrComment As String
End Type

Dim PrinterInfoArray() As PInfo1Full

Private Type PRN_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

Private Type NT_PRINTER_DEFAULTS
    pDatatype As String
    pDevMode As Long
    DesiredAccess As Long
End Type

Private Type OSVERSIONINFO
   dwOSVersionInfoSize As Long
   dwMajorVersion As Long
   dwMinorVersion As Long
   dwBuildNumber As Long
   dwPlatformId As Long
   strReserved As String * 128
End Type

Private Type PRN_INFO_5
    pPrinterName As Long
    pPortName As Long
    Attributes As Long
    DNST As Long
    TRT As Long
End Type

Private Type SET_PRN_INFO_5
    pPrinterName As String
    pPortName As String
    Attributes As Long
    DNST As Long
    TRT As Long
End Type

Private udtTargetPrinterData As SET_PRN_INFO_5

Private Declare Sub hmemcpy32 Lib "kernel32" Alias "RtlMoveMemory" (lpDest As Any, lpSource As Any, ByVal dwBytes As Long)
Private Declare Function EnumPrinters Lib "winspool.drv" Alias "EnumPrintersA" _
    (ByVal flags As Long, ByVal Name As String, ByVal Level As Long, _
    pPrinterEnum As Byte, ByVal cdBuf As Long, pcbNeeded As Long, _
    pcReturned As Long) As Long
Private Declare Function lstrcpy Lib "kernel32" Alias "lstrcpyA" (ByVal lpstrDest As String, ByVal lpSource 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 WriteProfileString Lib "kernel32" Alias "WriteProfileStringA" (ByVal LpszSection As String, ByVal lpszKeyName As String, ByVal lpszString As String) As Long
Private Declare Function OpenPrinter Lib "winspool.drv" Alias "OpenPrinterA" (ByVal pPrinterName As String, phPrinter As Long, pDefault As NT_PRINTER_DEFAULTS) 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 pPrinterName As String, lpDevModeOut As Byte, lpDevModeIn As Byte, ByVal fMode As Long) As Long
Private Declare Function GetPrinter Lib "winspool.drv" Alias "GetPrinterA" (ByVal hPrinter As Long, ByVal dwlevel As Long, pData As Byte, ByVal nSize As Long, pcbNeeded As Long) As Long
Private Declare Function SetPrinter Lib "winspool.drv" Alias "SetPrinterA" (ByVal hPrinter As Long, ByVal dwlevel As Long, ByVal Data As Long, ByVal dwState As Long) As Long
Private Declare Function SetPrinter2 Lib "winspool.drv" Alias "SetPrinterA" (ByVal hPrinter As Long, ByVal dwlevel As Long, pData As PRN_INFO_2, ByVal dwState As Long) As Long
Private Declare Function SetPrinter5 Lib "winspool.drv" Alias "SetPrinterA" (ByVal hPrinter As Long, ByVal dwlevel As Long, pData As PRN_INFO_5, ByVal dwState As Long) As Long
Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (lpOSInfo As OSVERSIONINFO) As Boolean

Dim bOrigOrientation As Byte, intOrigPaper%, intOrigTray%, lngOrigFields&, intOrigWidth%, intOrigLength%

Const PRINTER_STATUS_READY = &H0
Const PRINTER_STATUS_PAUSED = &H1
Const PRINTER_STATUS_ERROR = &H2
Const PRINTER_STATUS_PENDING_DELETION = &H4
Const PRINTER_STATUS_PAPER_JAM = &H8
Const PRINTER_STATUS_PAPER_OUT = &H10
Const PRINTER_STATUS_MANUAL_FEED = &H20
Const PRINTER_STATUS_PAPER_PROBLEM = &H40
Const PRINTER_STATUS_OFFLINE = &H80
Const PRINTER_STATUS_IO_ACTIVE = &H100
Const PRINTER_STATUS_BUSY = &H200
Const PRINTER_STATUS_PRINTING = &H400
Const PRINTER_STATUS_OUTPUT_BIN_FULL = &H800
Const PRINTER_STATUS_NOT_AVAILABLE = &H1000
Const PRINTER_STATUS_WAITING = &H2000
Const PRINTER_STATUS_PROCESSING = &H4000
Const PRINTER_STATUS_INITIALIZING = &H8000
Const PRINTER_STATUS_WARMING_UP = &H10000
Const PRINTER_STATUS_TONER_LOW = &H20000
Const PRINTER_STATUS_NO_TONER = &H40000
Const PRINTER_STATUS_PAGE_PUNT = &H80000
Const PRINTER_STATUS_USER_INTERVENTION = &H100000
Const PRINTER_STATUS_OUT_OF_MEMORY = &H200000
Const PRINTER_STATUS_DOOR_OPEN = &H400000

Const PRINTER_CONTROL_PAUSE = &H1
Const PRINTER_CONTROL_RESUME = &H2
Const PRINTER_CONTROL_PURGE = &H3

Private Const VER_PLATFORM_WINDOWS As Byte = 1
Private Const VER_PLATFORM_NT As Byte = 2
Private Const PRINTER_ATTRIBUTE_NETWORK = &H10
Private Const PRINTER_ATTRIBUTE_WORK_OFFLINE = &H400
Private Const PRINTER_ATTRIBUTE_WORK_ONLINE = &H401
Private Function atGetDefDevM(ByVal DefPrinterName$) As Variant
'-------------------------------------------------------
'Purpose:   Gets the current devmode for the specified printer.
'Accepts:   The name of a system printer (the default printer)
'Returns:   A "wide character" string which is misaligned for
'           a true devmode structure for the non string values.
'           To manipulate devmode use strconv to change to an
'           ansi string (vbfromUnicode)and then manipulate it
'           according to the narrow ansi devmode
'           structure (string values as 16 rather than 32).
'-----------------------------------------------------------------
On Error GoTo Err_GDD
Dim dwOK&, dwSize&, PtrhWnd&, dwReturnVal&
Dim PrinterName$
Dim varDevMode As Variant
Dim arrDevMode() As Byte
Dim Access As NT_PRINTER_DEFAULTS
    
Const PRINTER_ACCESS_USE = &H8
Const DM_OUT_BUFFER = 2

PrinterName = DefPrinterName
'Need to set the access rights for NT, ignored on 95
Access.pDatatype = vbNullString
Access.pDevMode = 0
Access.DesiredAccess = PRINTER_ACCESS_USE

dwOK = OpenPrinter(PrinterName, PtrhWnd, Access)
If dwOK <> 0 Then
    dwReturnVal = DocumentProperties(0, PtrhWnd, PrinterName, ByVal 0, ByVal 0, 0)
    If dwReturnVal > 2 Then
        ReDim arrDevMode(1 To dwReturnVal)
        dwReturnVal = DocumentProperties(0, PtrhWnd, PrinterName, arrDevMode(1), ByVal 0, DM_OUT_BUFFER)
        If dwReturnVal = 1 Then
            varDevMode = arrDevMode()
            atGetDefDevM = varDevMode
        Else
            atGetDefDevM = ""
        End If
    Else
        atGetDefDevM = ""
    End If
    Erase arrDevMode()
Else
    atGetDefDevM = ""
End If
Erase arrDevMode()
dwOK = ClosePrinter(PtrhWnd)
Exit_GDD:
    Exit Function
Err_GDD:
    atGetDefDevM = ""
    Resume Exit_GDD
End Function
Private Function atSetPrnProps&(strPrinter As String, boolReset As Boolean, Optional intOrientation As Byte, Optional intPaper As Integer, Optional intWidth As Integer, Optional intLength As Integer, Optional intTray As Integer)
'-------------------------------------
'Purpose:  Sets the default printer's paper, orientation, tray as desired.
'Accepts:  strPrinter: Name of a Printer - SetPrinterProps
'          boolReset: False to set the desired settings, true to reset to original
'--------------------------------------
On Error GoTo Err_SPP
Dim dwOK As Long
Dim udtPrnAccess As NT_PRINTER_DEFAULTS
Dim varOrigDevMode As Variant
Dim arrPrinterArray() As Byte
Dim arrDevMode() As Byte
Dim dmAnsiStructOnlyStr As udtDevModeStrShort
Dim hWndPrinter As Long, lngArrayNeeded As Long, intDMLen As Integer
Dim udtPrnData As PRN_INFO_2
Dim udtDM As udtDevModeAnsi, udtDMstr As udtDevModeStr
Const PRINTER_ACCESS_ADMINISTER = &H4
Const PRINTER_ACCESS_USE = &H8
Const STANDARD_RIGHTS_REQUIRED = &HF0000
Const DM_PAPERSIZE = &H2&
Const DM_PAPERLENGTH = &H4&
Const DM_PAPERWIDTH = &H8&
Const DM_DEFAULTSOURCE As Long = &H200

'first get the default devmode
varOrigDevMode = atGetDefDevM(strPrinter)
If Len(varOrigDevMode) < 1 Then
    atSetPrnProps = &H10
    Exit Function
End If
'set the byte array into the struct
udtDMstr.RGB = varOrigDevMode
LSet udtDM = udtDMstr
intDMLen = udtDM.dmSize + udtDM.dmDriverExtra
If boolReset = False Then
    lngOrigFields = udtDM.dmFields
    If (intOrientation > 0) And (intOrientation = 1 Or intOrientation = 2) Then
        bOrigOrientation = udtDM.dmOrientation
        udtDM.dmOrientation = intOrientation
    End If
    If intPaper > 0 Then
        intOrigPaper = udtDM.dmPaperSize
        udtDM.dmPaperSize = intPaper
        udtDM.dmFields = udtDM.dmFields Or DM_PAPERSIZE
        If intWidth > 0 And intPaper = 256 Then
            intOrigWidth = udtDM.dmPaperWidth
            udtDM.dmPaperWidth = intWidth
            udtDM.dmFields = udtDM.dmFields Or DM_PAPERWIDTH
        End If
        If intLength > 0 And intPaper = 256 Then
            intOrigLength = udtDM.dmPaperLength
            udtDM.dmPaperLength = intLength
            udtDM.dmFields = udtDM.dmFields Or DM_PAPERLENGTH
        End If
    End If
    If intTray >= 1 Then
        intOrigTray = udtDM.dmDefaultSource
        udtDM.dmDefaultSource = intTray
        udtDM.dmFields = udtDM.dmFields Or DM_DEFAULTSOURCE
    End If
Else
    If bOrigOrientation > 0 Then
        udtDM.dmOrientation = bOrigOrientation
    End If
    If intOrigPaper > 0 Then
        udtDM.dmPaperSize = intOrigPaper
        If intOrigWidth > 0 Then
            udtDM.dmPaperWidth = intOrigWidth
        End If
        If intOrigLength > 0 Then
            udtDM.dmPaperLength = intOrigLength
        End If
    End If
    If intOrigTray > 0 Then
        udtDM.dmDefaultSource = intOrigTray
    End If
    udtDM.dmFields = lngOrigFields
    bOrigOrientation = 0
    intOrigPaper = 0
    intOrigTray = 0
End If
LSet dmAnsiStructOnlyStr = udtDM
Mid(udtDMstr.RGB, 1, 54) = dmAnsiStructOnlyStr.RGB
udtDMstr.RGB = StrConv(udtDMstr.RGB, vbUnicode)

udtPrnAccess.pDatatype = vbNullString
udtPrnAccess.pDevMode = 0
udtPrnAccess.DesiredAccess = PRINTER_ACCESS_USE Or STANDARD_RIGHTS_REQUIRED Or PRINTER_ACCESS_ADMINISTER
dwOK = OpenPrinter(strPrinter, hWndPrinter, udtPrnAccess)
If hWndPrinter = 0 Then
    atSetPrnProps = &H20
    dwOK = ClosePrinter(hWndPrinter)
    GoTo Exit_SPP
Else
    dwOK = GetPrinter(hWndPrinter, 2, 0, 0, lngArrayNeeded)
    ReDim arrPrinterArray(lngArrayNeeded) As Byte
    dwOK = GetPrinter(hWndPrinter, 2, arrPrinterArray(0), lngArrayNeeded, lngArrayNeeded)
    Call hmemcpy32(udtPrnData, arrPrinterArray(0), Len(udtPrnData))
    Call hmemcpy32(ByVal udtPrnData.pDevMode, ByVal udtDMstr.RGB, intDMLen)
    dwOK = SetPrinter2(hWndPrinter, 2, udtPrnData, 0&)
    If dwOK = False Then
        atSetPrnProps = &H40
    End If
    dwOK = ClosePrinter(hWndPrinter)
End If
atSetPrnProps = True
Exit_SPP:
    Exit Function
Err_SPP:
    atSetPrnProps = False
    dwOK = ClosePrinter(hWndPrinter)
    Resume Exit_SPP
End Function

Private Function atWinver(intOSInfo As Byte) As Variant
Dim osinfo As OSVERSIONINFO

osinfo.dwOSVersionInfoSize = Len(osinfo)
If GetVersionEx(osinfo) Then
   Select Case intOSInfo
      Case 0
         atWinver = osinfo.dwMajorVersion
      Case 1
         atWinver = osinfo.dwPlatformId
   End Select
Else
   atWinver = 0
End If
End Function

Private Function pFixString$(ByVal szStringwNulls$)
'--------------------------------------------------------------------
'This function strips the trailing Nulls that StrConv leaves from the
'presized string variables.
'--------------------------------------------------------------------
If (InStr(szStringwNulls, Chr$(0))) Then pFixString = left$(szStringwNulls, InStr(szStringwNulls, Chr$(0)) - 1)
   
End Function

Private Sub pEnumPrint()
On Error GoTo Err_EP
Dim PrinterBuffArray() As Byte
Dim PrinterPointer As PINFO1
Dim dwReturn As Long
Dim BuffNeeded&
Dim Buffsz&, i As Byte, j As Integer, intLoop As Integer
Dim NumPrinters&
Dim ArrayAddress&
Dim tempstr$, BoolSortTest As Boolean
Dim PrinterInfoTemp As PInfo1Full

Const PRINTER_ENUM_LOCAL As Long = &H2
Const PRINTER_ENUM_CONNECTIONS As Long = &H4

dwReturn = EnumPrinters(PRINTER_ENUM_LOCAL Or PRINTER_ENUM_CONNECTIONS, 0&, 1, 0&, 0, BuffNeeded, NumPrinters)
ReDim PrinterBuffArray(BuffNeeded) As Byte
dwReturn = EnumPrinters(PRINTER_ENUM_LOCAL Or PRINTER_ENUM_CONNECTIONS, 0&, 1, PrinterBuffArray(0), BuffNeeded, BuffNeeded, NumPrinters)
ReDim PrinterInfoArray(NumPrinters) As PInfo1Full
If NumPrinters > 0 Then
    For i = 0 To UBound(PrinterInfoArray) - 1
        j = i * Len(PrinterPointer)
        Call hmemcpy32(PrinterPointer, PrinterBuffArray(j), Len(PrinterPointer))
        PrinterInfoArray(i).dwFlags = PrinterPointer.dwFlags
        PrinterInfoArray(i).lpstrDescription = String(255, 0)
        dwReturn = lstrcpy(PrinterInfoArray(i).lpstrDescription, PrinterPointer.dwDescription)
        PrinterInfoArray(i).lpstrDescription = pFixString(PrinterInfoArray(i).lpstrDescription)
        PrinterInfoArray(i).lpstrName = String(255, 0)
        dwReturn = lstrcpy(PrinterInfoArray(i).lpstrName, PrinterPointer.dwName)
        PrinterInfoArray(i).lpstrName = pFixString(PrinterInfoArray(i).lpstrName)
        PrinterInfoArray(i).lpstrComment = String(255, 0)
        dwReturn = lstrcpy(PrinterInfoArray(i).lpstrComment, PrinterPointer.dwComment)
        PrinterInfoArray(i).lpstrComment = pFixString(PrinterInfoArray(i).lpstrComment)
    Next i
Else
    Exit Sub
End If

'Sort 'em alpha with a simple bubble sort since its a small list
BoolSortTest = True
Do Until BoolSortTest = False
  BoolSortTest = False
  For intLoop = 0 To UBound(PrinterInfoArray()) - 1
     If (PrinterInfoArray(intLoop).lpstrName > PrinterInfoArray(intLoop + 1).lpstrName) And Len(PrinterInfoArray(intLoop + 1).lpstrName) > 0 Then
        PrinterInfoTemp = PrinterInfoArray(intLoop)
        PrinterInfoArray(intLoop) = PrinterInfoArray(intLoop + 1)
        PrinterInfoArray(intLoop + 1) = PrinterInfoTemp
        BoolSortTest = True
     End If
  Next intLoop
Loop

Exit_EP:
    Exit Sub
Err_EP:
    Erase PrinterInfoArray()
    Resume Exit_EP
End Sub

Public Sub GetAvailPrinters(ByRef strPrinterArray() As String)
On Error GoTo Err_GAP:
Dim intI%
Dim strReturn$

Call pEnumPrint
ReDim strPrinterArray(UBound(PrinterInfoArray()) - 1)
For intI = 0 To UBound(PrinterInfoArray()) - 1
    strPrinterArray(intI) = PrinterInfoArray(intI).lpstrName
Next intI

Exit_GAP:
    Exit Sub
Err_GAP:
    'Send back 0 printers.
    'Usually occurs for a bounds error when there are no printers
    ReDim strPrinterArray(0)
    strPrinterArray(0) = "No printers installed or found"
    Resume Exit_GAP
End Sub

Public Property Get CurrentDefaultPrinter() As String
    CurrentDefaultPrinter = atCurrentDefault()
End Property
Private Function SetAppPrinter(strPrinterName As String)
On Error Resume Next
Dim objPrn As Object
Dim App As Object
Dim strPrinter As String
Set App = Application
If Val(SysCmd(acSysCmdAccessVer)) >= 10 Then
    For Each objPrn In App.Printers
        strPrinter = objPrn.DeviceName
        If strPrinter = strPrinterName Then
            Set App.Printer = objPrn
        End If
    Next
End If
End Function
Public Function SetDefaultPrinter(ByVal strDesiredDefault As String) As Integer
On Error GoTo Err_SDP
Dim intI%, dwOK&, lnghPrinter&
Dim strPrnBuff As String
Dim tempstr$, bPlatform As Byte
Dim boolFound As Boolean, intChrCount%, strTempVal$
Dim arrPrintInfo() As Byte
Dim udtPrinter5 As PRN_INFO_5, lngBytesNeeded&
Dim udtPrnAccess As NT_PRINTER_DEFAULTS
Const PRINTER_ACCESS_ADMINISTER = &H4
Const PRINTER_ACCESS_USE = &H8
Const STANDARD_RIGHTS_REQUIRED = &HF0000

Const szBuff As Long = 1024
Const PRINTER_ATTRIBUTE_DEFAULT = 4

Call pEnumPrint
bPlatform = atWinver(1)
strPrnBuff = Space$(szBuff)
For intI = 0 To UBound(PrinterInfoArray()) - 1
    If strDesiredDefault = PrinterInfoArray(intI).lpstrName Then
        boolFound = True
    End If
Next intI
SetDefaultPrinter = True

If boolFound = True Then
    If bPlatform = VER_PLATFORM_NT Then  'NT/2000
        SetAppPrinter strDesiredDefault
        dwOK = GetProfileString("Devices", strDesiredDefault, "Missing", strPrnBuff, szBuff)
        tempstr = left$(strPrnBuff, dwOK)
        If tempstr = "Missing" Or Len(tempstr) = 0 Then
            SetDefaultPrinter = &H4  'Error value
            'Can't set the selected printer, printer or system settings not found.
            Exit Function
        End If
                
        dwOK = WriteProfileString("Windows", "Device", strDesiredDefault & "," & tempstr)
        If dwOK = 0 Then
           SetDefaultPrinter = &H8
           'Can't set the select printer, system will not accept settings. Check registry or security.
        End If
    Else ' Windows 95/98/Millenium Only not supported on NT or 2000
        udtPrnAccess.pDatatype = vbNullString
        udtPrnAccess.pDevMode = 0
        udtPrnAccess.DesiredAccess = PRINTER_ACCESS_USE Or STANDARD_RIGHTS_REQUIRED Or PRINTER_ACCESS_ADMINISTER
        dwOK = OpenPrinter(strDesiredDefault, lnghPrinter, udtPrnAccess)
        If dwOK = 0 Then
            SetDefaultPrinter = &H4
        Else
            dwOK = GetPrinter(lnghPrinter, 5, 0&, 0, lngBytesNeeded)
            ReDim arrPrintInfo(lngBytesNeeded)
            dwOK = GetPrinter(lnghPrinter, 5, arrPrintInfo(0), lngBytesNeeded, lngBytesNeeded)
            If dwOK = 0 Then
                dwOK = ClosePrinter(lnghPrinter)
                SetDefaultPrinter = &H4
                Exit Function
            End If
            Call hmemcpy32(udtPrinter5, arrPrintInfo(0), Len(udtPrinter5))
            udtPrinter5.Attributes = udtPrinter5.Attributes Or PRINTER_ATTRIBUTE_DEFAULT
            dwOK = SetPrinter5(lnghPrinter, 5, udtPrinter5, 0&)
            If dwOK = 0 Then
                SetDefaultPrinter = &H8
            End If
        End If
        dwOK = ClosePrinter(lnghPrinter)
    End If
Else
    SetDefaultPrinter = &H2
    'Printer not found
End If

Exit_SDP:
    Exit Function
Err_SDP:
    SetDefaultPrinter = False
    Resume Exit_SDP
End Function

Private Sub Class_Terminate()
Erase PrinterInfoArray()
bOrigOrientation = 0
intOrigPaper = 0
intOrigTray = 0
lngOrigFields = 0
End Sub



Private Function atCurrentDefault() As String
On Error GoTo Err_CDP
Dim strPrnBuff As String
Dim strDefaultDevice$, tempstr$
Dim intPosition%, dwOK&
Const szBuff As Long = 1024

strPrnBuff = Space$(szBuff)

dwOK = GetProfileString("Windows", "Device", "Missing", strPrnBuff, szBuff)
tempstr = left$(strPrnBuff, dwOK)
If tempstr = "Missing" Or Len(tempstr) = 0 Then
    strDefaultDevice = ""
Else
    intPosition = InStr(tempstr, ",")
    If intPosition > 0 Then
        strDefaultDevice = left(tempstr, intPosition - 1)
    Else
        strDefaultDevice = tempstr
    End If
End If
atCurrentDefault = strDefaultDevice
Exit_CDP:
    Exit Function
Err_CDP:
    atCurrentDefault = ""
    Resume Exit_CDP
End Function

Public Function SetPrinterProps(Optional ByVal Orientation As Byte, Optional ByVal Paper As Integer, Optional ByVal Width As Integer, Optional ByVal Length As Integer, Optional ByVal Tray As Integer) As Long
Dim strCurDefaultPrn As String
Dim wOK As Long

If Orientation = 0 And Paper = 0 And Tray = 0 Then
    Exit Function
    SetPrinterProps = False
Else
    strCurDefaultPrn = atCurrentDefault()
    If Len(strCurDefaultPrn) > 0 Then
        wOK = atSetPrnProps(strCurDefaultPrn, False, Orientation, Paper, Width, Length, Tray)
        If wOK = True Then
            SetPrinterProps = True
        Else
            SetPrinterProps = wOK
        End If
    Else
        SetPrinterProps = False
        Exit Function
    End If
End If

End Function

Public Sub ResetPrinterProps()
Dim strCurDefaultPrn As String
Dim wOK&
strCurDefaultPrn = atCurrentDefault()
wOK = atSetPrnProps(strCurDefaultPrn, True)

End Sub

Public Function GetPrinterStatus(strPrinter As String, Optional strOutputPort As String, Optional lngPrinterAttributes As Long, Optional lngPrinterJobs As Long) As Long
'Gets not only the status but also the fills the attributes and port data
On Error Resume Next
Dim dwOK&
Dim arrPrinterInfo() As Byte
Dim hPrinter&, lngBytesNeeded&
Dim udtPrinter2 As PRN_INFO_2
Dim strPort As String
Dim udtPrnAccess As NT_PRINTER_DEFAULTS
Const PRINTER_ACCESS_USE = &H8
Const STANDARD_RIGHTS_REQUIRED = &HF0000

GetPrinterStatus = &H1000
udtPrnAccess.pDatatype = vbNullString
udtPrnAccess.pDevMode = 0
udtPrnAccess.DesiredAccess = PRINTER_ACCESS_USE Or STANDARD_RIGHTS_REQUIRED
dwOK = OpenPrinter(strPrinter, hPrinter, udtPrnAccess)
If dwOK <> 0 Then
    dwOK = GetPrinter(hPrinter, 2, ByVal 0, lngBytesNeeded, lngBytesNeeded)
    If lngBytesNeeded = 0 Then
        Exit Function
    End If
    ReDim arrPrinterInfo(1 To lngBytesNeeded)
    dwOK = GetPrinter(hPrinter, 2, arrPrinterInfo(1), lngBytesNeeded, lngBytesNeeded)
    If dwOK = 0 Then
        Exit Function
    End If
    Call hmemcpy32(udtPrinter2, arrPrinterInfo(1), Len(udtPrinter2))
    Erase arrPrinterInfo()
    dwOK = ClosePrinter(hPrinter)
    GetPrinterStatus = udtPrinter2.Status
    
    'Fill up the Target Printer data for return
    strPort = String(255, 0)
    dwOK = lstrcpy(strPort, udtPrinter2.pPortName)
    strOutputPort = pFixString(strPort)
    lngPrinterAttributes = udtPrinter2.Attributes
    lngPrinterJobs = udtPrinter2.cJobs
Else
    dwOK = ClosePrinter(hPrinter)
End If
End Function


Public Function SetPrinterState(Printer As String, StateDesired As Long) As Long
'Gets not only the status but also the fills the attributes and port data
On Error Resume Next
Dim dwOK&, dwReturn&
Dim arrPrinterInfo() As Byte
Dim hPrinter&, lngBytesNeeded&
Dim udtPrinter2 As PRN_INFO_2
Dim udtPrnAccess As NT_PRINTER_DEFAULTS
Const PRINTER_ACCESS_USE = &H8
Const STANDARD_RIGHTS_REQUIRED = &HF0000
Const PRINTER_ACCESS_ADMINISTER = &H4
Const PRINTER_CONTROL_SET_STATUS = &H4

SetPrinterState = 0

udtPrnAccess.pDatatype = vbNullString
udtPrnAccess.pDevMode = 0
udtPrnAccess.DesiredAccess = PRINTER_ACCESS_ADMINISTER Or PRINTER_ACCESS_USE Or STANDARD_RIGHTS_REQUIRED
dwOK = OpenPrinter(Printer, hPrinter, udtPrnAccess)
If dwOK <> 0 Then
    Select Case StateDesired
    Case PRINTER_CONTROL_PAUSE, PRINTER_CONTROL_RESUME, PRINTER_CONTROL_PURGE
        dwReturn = SetPrinter(hPrinter, 0, CByte(vbNull), StateDesired)
    Case PRINTER_ATTRIBUTE_WORK_OFFLINE
        dwOK = GetPrinter(hPrinter, 2, 0, 0, lngBytesNeeded)
        ReDim arrPrinterArray(lngBytesNeeded) As Byte
        dwOK = GetPrinter(hPrinter, 2, arrPrinterArray(0), lngBytesNeeded, lngBytesNeeded)
        Call hmemcpy32(udtPrinter2, arrPrinterArray(0), Len(udtPrinter2))
        udtPrinter2.Attributes = udtPrinter2.Attributes Or PRINTER_ATTRIBUTE_WORK_OFFLINE
        dwReturn = SetPrinter2(hPrinter, 2, udtPrinter2, 0&)
    Case PRINTER_ATTRIBUTE_WORK_ONLINE
        dwOK = GetPrinter(hPrinter, 2, 0, 0, lngBytesNeeded)
        ReDim arrPrinterArray(lngBytesNeeded) As Byte
        dwOK = GetPrinter(hPrinter, 2, arrPrinterArray(0), lngBytesNeeded, lngBytesNeeded)
        Call hmemcpy32(udtPrinter2, arrPrinterArray(0), Len(udtPrinter2))
        udtPrinter2.Attributes = udtPrinter2.Attributes And Not PRINTER_ATTRIBUTE_WORK_OFFLINE
        dwReturn = SetPrinter2(hPrinter, 2, udtPrinter2, 0&)
    Case Else
        SetPrinterState = 0
    End Select
    SetPrinterState = dwReturn
    dwOK = ClosePrinter(hPrinter)
Else
    dwOK = ClosePrinter(hPrinter)
End If
End Function