Module m_WinSpool

  <StructLayout(LayoutKind.Sequential)>
  Public Structure POINTL
    Dim x As Integer
    Dim y As Integer
  End Structure

  'GDI Print API Structures

  ' Constants for DEVMODE
  Public Const CCHDEVICENAME = 32
  Public Const CCHFORMNAME = 32

  <StructLayout(LayoutKind.Sequential, CharSet:=CharSet.Unicode)>
  Public Structure DEVMODE
    <MarshalAs(UnmanagedType.ByValTStr, Sizeconst:=CCHDEVICENAME)> Dim pDeviceName As String
    Dim dmSpecVersion As Short
    Dim dmDriverVersion As Short
    Dim dmSize As Short
    Dim dmDriverExtra As Short
    Dim dmFields As Integer
    Dim dmOrientation As Short 'Union-начало
    Dim dmPaperSize As Short
    Dim dmPaperLength As Short
    Dim dmPaperWidth As Short
    Dim dmScale As Short
    Dim dmCopies As Short
    Dim dmDefaultSource As Short
    Dim dmPrintQuality As Short 'Union-конец
    Dim dmColor As Short
    Dim dmDuplex As Short
    Dim dmYResolution As Short
    Dim dmTTOption As Short
    Dim dmCollate As Short
    <MarshalAs(UnmanagedType.ByValTStr, Sizeconst:=CCHFORMNAME)> Dim dmFormName As String
    Dim dmLogPixels As Short
    Dim dmBitsPerPel As Integer
    Dim dmPelsWidth As Integer
    Dim dmPelsHeight As Integer
    Dim dmDisplayFlags As Integer 'Union
    Dim dmDisplayFrequency As Integer
    ' The following only appear in Windows 95, 98, 2000 (WINVER >= 0x0400)
    Dim dmICMMethod As Integer
    Dim dmICMIntent As Integer
    Dim dmMediaType As Integer
    Dim dmDitherType As Integer
    Dim dmReserved1 As Integer
    Dim dmReserved2 As Integer
    ' The following only appear in Windows 2000 (WINVER >= 0x0500) || (_WIN32_WINNT >= 0x0400)
    Dim dmPanningWidth As Integer
    Dim dmPanningHeight As Integer
  End Structure

  'Print Spooler API Structures

  ' DesiredAccess - Specifies desired access rights for a printer.
  Public Const PRINTER_ACCESS_USE = &H8

  <StructLayout(LayoutKind.Sequential, CharSet:=CharSet.Unicode)>
  Public Structure PRINTER_DEFAULTS
    Dim pDatatype As String
    Dim pDevMode As DEVMODE
    Dim DesiredAccess As Integer
  End Structure

  <StructLayout(LayoutKind.Sequential, CharSet:=CharSet.Unicode)>
  Public Structure PRINTER_INFO_9
    Dim pDevMode As IntPtr ' Pointer to DEVMODE
  End Structure

  'Print Spooler API Functions
  Public Declare Function ClosePrinter Lib "winspool.drv" _
   (ByVal hPrinter As IntPtr) As Boolean

  ' fMode - The operations the function performs.
  Public Const DM_MODIFY = 8
  Public Const DM_COPY = 2
  Public Const DM_IN_BUFFER = DM_MODIFY
  Public Const DM_OUT_BUFFER = DM_COPY

  Public Declare Unicode Function DocumentProperties Lib "winspool.drv" _
   Alias "DocumentPropertiesW" (ByVal hwnd As IntPtr, _
   ByVal hPrinter As IntPtr, ByVal pDeviceName As String, _
   ByVal pDevModeOutput As IntPtr, ByVal pDevModeInput As IntPtr, _
   ByVal fMode As Integer) As Integer
  Public Declare Unicode Function GetPrinter Lib "winspool.drv" Alias _
   "GetPrinterW" (ByVal hPrinter As IntPtr, ByVal Level As Integer, _
   pPrinter As IntPtr, ByVal cbBuf As Integer, ByRef pcbNeeded As Integer) As Long
  Public Declare Unicode Function OpenPrinter Lib "winspool.drv" Alias _
   "OpenPrinterW" (ByVal pPrinterName As String, ByRef phPrinter As IntPtr, _
   ByRef pDefault As PRINTER_DEFAULTS) As Boolean
  Public Declare Unicode Function SetPrinter Lib "winspool.drv" Alias _
   "SetPrinterW" (ByVal hPrinter As IntPtr, ByVal Level As Integer, _
   ByVal pPrinter As IntPtr, ByVal Command As Integer) As Boolean

  Public Function SetGetPrinterQuality(Optional ByRef lPrevQuality As String = vbNullString, _
   Optional ByVal sPrinterName As String = vbNullString, _
   Optional ByVal nNewQuality As String = vbNullString, _
   Optional ByVal bSet As Boolean = False, _
   Optional ByRef sErrMsg As String = vbNullString) As Boolean

    Dim hPrinter As IntPtr
    Dim pd As New PRINTER_DEFAULTS
    Dim pinfo As PRINTER_INFO_9
    Dim dm As New DEVMODE

    Dim pBufferDevModeData As IntPtr
    Dim pBufferInfoMemory As IntPtr
    Dim nBytesNeeded As Integer
    Dim nRet As Integer

    SetGetPrinterQuality = False

    pd.DesiredAccess = PRINTER_ACCESS_USE
    If OpenPrinter(sPrinterName & Chr(0), hPrinter, pd) = False Then
      'Debug.Print("OpenPrinter failed: " & RaiseAPIErrorByNumber(Err.LastDllError))
      sErrMsg = "OpenPrinter failed: " & RaiseAPIErrorByNumber(Err.LastDllError)
      Exit Function
    End If

    nRet = DocumentProperties(IntPtr.Zero, hPrinter, sPrinterName & Chr(0), IntPtr.Zero, IntPtr.Zero, 0)
    If (nRet < 0) Then
      'Debug.Print("DocumentProperties failed: " & RaiseAPIErrorByNumber(Err.LastDllError))
      sErrMsg = "DocumentProperties failed: " & RaiseAPIErrorByNumber(Err.LastDllError)
      GoTo cleanup
    End If

    pBufferDevModeData = Marshal.AllocHGlobal(nRet)
    nRet = DocumentProperties(IntPtr.Zero, hPrinter, sPrinterName & Chr(0), _
     pBufferDevModeData, IntPtr.Zero, DM_OUT_BUFFER)
    If (nRet < 0) Then
      'Debug.Print("DocumentProperties failed: " & RaiseAPIErrorByNumber(Err.LastDllError))
      sErrMsg = "DocumentProperties failed: " & RaiseAPIErrorByNumber(Err.LastDllError)
      GoTo cleanup
    End If
    dm = Marshal.PtrToStructure(pBufferDevModeData, GetType(DEVMODE))

    lPrevQuality = dm.dmPrintQuality & "x" & dm.dmYResolution

    If Not bSet Then
      SetGetPrinterQuality = True
      GoTo cleanup
    End If
    Select Case nNewQuality
      Case "200x200"
        dm.dmPrintQuality = 200
        dm.dmYResolution = 200
      Case "200x100"
        dm.dmPrintQuality = 200
        dm.dmYResolution = 100
      Case Else
        GoTo cleanup
    End Select
    Marshal.StructureToPtr(dm, pBufferDevModeData, True)

    nRet = DocumentProperties(0, hPrinter, sPrinterName & Chr(0), _
     pBufferDevModeData, pBufferDevModeData, _
     DM_IN_BUFFER Or DM_OUT_BUFFER)
    If (nRet < 0) Then
      'Debug.Print("DocumentProperties failed: " & RaiseAPIErrorByNumber(Err.LastDllError))
      sErrMsg = "DocumentProperties failed: " & RaiseAPIErrorByNumber(Err.LastDllError)
      GoTo cleanup
    End If

    Call GetPrinter(hPrinter, 9, IntPtr.Zero, 0, nBytesNeeded)
    If (nBytesNeeded = 0) Then GoTo cleanup

    pBufferInfoMemory = Marshal.AllocHGlobal(nBytesNeeded)

    If GetPrinter(hPrinter, 9, pBufferInfoMemory, nBytesNeeded, 0) = False Then
      'Debug.Print("GetPrinter failed: " & RaiseAPIErrorByNumber(Err.LastDllError))
      sErrMsg = "GetPrinter failed: " & RaiseAPIErrorByNumber(Err.LastDllError)
      GoTo cleanup
    End If

    pinfo = Marshal.PtrToStructure(pBufferInfoMemory, GetType(PRINTER_INFO_9))

    pinfo.pDevMode = pBufferDevModeData
    Marshal.StructureToPtr(pinfo, pBufferInfoMemory, True)

    If SetPrinter(hPrinter, 9, pBufferInfoMemory, 0) = False Then
      'Debug.Print("SetPrinter failed: " & RaiseAPIErrorByNumber(Err.LastDllError))
      sErrMsg = "SetPrinter failed: " & RaiseAPIErrorByNumber(Err.LastDllError)
    Else
      SetGetPrinterQuality = True
    End If

cleanup:
    If (hPrinter <> IntPtr.Zero) Then Call ClosePrinter(hPrinter)

    If Not pBufferDevModeData.Equals(0) Then
      Marshal.FreeHGlobal(pBufferDevModeData)
    End If
    If Not pBufferInfoMemory.Equals(0) Then
      Marshal.FreeHGlobal(pBufferInfoMemory)
    End If
  End Function

  Public Function RaiseAPIErrorByNumber(ByVal ErrNum As Integer) As String
    Return ErrNum.ToString & " (" & (New System.ComponentModel.Win32Exception(ErrNum)).Message & ")"
  End Function

  Public Function SetGetPrinterQuality2(Optional ByRef lPrevQuality As String = vbNullString, _
   Optional ByVal sPrinterName As String = vbNullString, _
   Optional ByVal nNewQuality As String = vbNullString, _
   Optional ByVal bSet As Boolean = False, _
   Optional ByRef sErrMsg As String = vbNullString) As Boolean

    Dim hPrinter As IntPtr
    Dim pd As New PRINTER_DEFAULTS
    Dim pinfo As PRINTER_INFO_9
    Dim dm As New DEVMODE

    Dim pBufferInfoMemory As IntPtr
    Dim nBytesNeeded As Integer

    SetGetPrinterQuality2 = False

    pd.DesiredAccess = PRINTER_ACCESS_USE
    If OpenPrinter(sPrinterName & Chr(0), hPrinter, pd) = False Then
      'Debug.Print("OpenPrinter failed: " & RaiseAPIErrorByNumber(Err.LastDllError))
      sErrMsg = "OpenPrinter failed: " & RaiseAPIErrorByNumber(Err.LastDllError)
      Exit Function
    End If

    Call GetPrinter(hPrinter, 9, IntPtr.Zero, 0, nBytesNeeded)
    If (nBytesNeeded = 0) Then GoTo cleanup

    pBufferInfoMemory = Marshal.AllocHGlobal(nBytesNeeded)

    If GetPrinter(hPrinter, 9, pBufferInfoMemory, nBytesNeeded, 0) = False Then
      'Debug.Print("GetPrinter failed: " & RaiseAPIErrorByNumber(Err.LastDllError))
      sErrMsg = "GetPrinter failed: " & RaiseAPIErrorByNumber(Err.LastDllError)
      GoTo cleanup
    End If

    pinfo = Marshal.PtrToStructure(pBufferInfoMemory, GetType(PRINTER_INFO_9))
    dm = Marshal.PtrToStructure(pinfo.pDevMode, GetType(DEVMODE))
    lPrevQuality = dm.dmPrintQuality & "x" & dm.dmYResolution
    If Not bSet Then
      SetGetPrinterQuality2 = True
      GoTo cleanup
    End If
    Select Case nNewQuality
      Case "200x200"
        dm.dmPrintQuality = 200
        dm.dmYResolution = 200
      Case "200x100"
        dm.dmPrintQuality = 200
        dm.dmYResolution = 100
      Case Else
        GoTo cleanup
    End Select
    Marshal.StructureToPtr(dm, pinfo.pDevMode, True)
    Marshal.StructureToPtr(pinfo, pBufferInfoMemory, True)

    If SetPrinter(hPrinter, 9, pBufferInfoMemory, 0) = False Then
      'Debug.Print("SetPrinter failed: " & RaiseAPIErrorByNumber(Err.LastDllError))
      sErrMsg = "SetPrinter failed: " & RaiseAPIErrorByNumber(Err.LastDllError)
    Else
      SetGetPrinterQuality2 = True
    End If

cleanup:
    If (hPrinter <> IntPtr.Zero) Then Call ClosePrinter(hPrinter)

    If Not pBufferInfoMemory.Equals(0) Then
      Marshal.FreeHGlobal(pBufferInfoMemory)
    End If
  End Function