Druckertreiber per VBA ansteuern

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Ingo,
versuch es mal so:

' **********************************************************************
' Modul: Modul8 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Private Declare Function OpenPrinter Lib "winspool.drv" Alias "OpenPrinterA" ( _
    ByVal pPrinterName As String, _
    ByRef phPrinter As Long, _
    ByRef pDefault As PRINTER_DEFAULTS) 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 Long, _
    ByVal pDevModeInput As Long, _
    ByVal fMode As Long) As Long
Private Declare Function GetPrinter Lib "winspool.drv" Alias "GetPrinterA" ( _
    ByVal hPrinter As Long, _
    ByVal Level As Long, _
    ByRef pPrinter As Byte, _
    ByVal cbBuf As Long, _
    ByRef pcbNeeded As Long) As Long
Private Declare Function SetPrinter Lib "winspool.drv" Alias "SetPrinterA" ( _
    ByVal hPrinter As Long, _
    ByVal Level As Long, _
    ByRef pPrinter As Byte, _
    ByVal Command As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
    ByRef pDest As Any, _
    ByRef pSource As Any, _
    ByVal cbLength As Long)
Private Declare Function ClosePrinter Lib "winspool.drv" ( _
    ByVal hPrinter As Long) As Long

Private Type PRINTER_DEFAULTS
    pDatatype As Long
    pDevmode As Long
    DesiredAccess As Long
End Type

Private 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

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
    dmUnusedPadding As Integer
    dmBitsPerPel As Integer
    dmPelsWidth As Long
    dmPelsHeight As Long
    dmDisplayFlags As Long
    dmDisplayFrequency As Long
    dmICMMethod As Long
    dmICMIntent As Long
    dmMediaType As Long
    dmDitherType As Long
    dmReserved1 As Long
    dmReserved2 As Long
End Type

Private Const PRINTER_ACCESS_USE = &H8
Private Const STANDARD_RIGHTS_REQUIRED = &HF0000
Private Const PRINTER_NORMAL_ACCESS = (STANDARD_RIGHTS_REQUIRED Or _
    PRINTER_ACCESS_USE)

Private Const DM_ORIENTATION = &H1
Private Const DM_PAPERSIZE = &H2
Private Const DM_PAPERLENGTH = &H4
Private Const DM_PAPERWIDTH = &H8
Private Const DM_DEFAULTSOURCE = &H200
Private Const DM_PRINTQUALITY = &H400
Private Const DM_COLOR = &H800
Private Const DM_DUPLEX = &H1000
Private Const DM_IN_BUFFER = 8
Private Const DM_OUT_BUFFER = 2

Public Sub test1()
    MsgBox GetColorMode
End Sub

Public Sub test2()
    Dim lngColorMode As Long
    lngColorMode = GetColorMode
    Call SetColorMode(2) '1 schwarzweiß / 2 Farbe
    ActiveSheet.PrintOut
    Call SetColorMode(lngColorMode) 'Reset to Default
End Sub

Public Sub SetColorMode(iColorMode As Long)
    SetPrinterProperty DM_COLOR, iColorMode
End Sub

Public Function GetColorMode() As Long
    GetColorMode = GetPrinterProperty(DM_COLOR)
End Function

Private Function SetPrinterProperty(ByVal lngPropertyType As Long, _
        ByVal lngPropertyValue As Long) As Boolean
    Dim udtPD As PRINTER_DEFAULTS
    Dim udtPI As PRINTER_INFO_2
    Dim udtDM As DEVMODE
    Dim strPrinterName As String
    Dim bytDevModeData() As Byte, bytPInfoMemory() As Byte
    Dim lngPrinter As Long, lngBytesNeeded As Long
    Dim lngReturn As Long, lngJunk As Long
    On Error GoTo err_exit
    strPrinterName = Trim$(Left$(ActivePrinter, _
        InStr(ActivePrinter, " auf ")))
    udtPD.DesiredAccess = PRINTER_NORMAL_ACCESS
    lngReturn = OpenPrinter(strPrinterName, lngPrinter, udtPD)
    If (lngReturn = 0) Or (lngPrinter = 0) Then Exit Function
    lngReturn = DocumentProperties(0, lngPrinter, strPrinterName, 0, 0, 0)
    If (lngReturn < 0) Then Err.Raise vbObjectError + 1
    Redim bytDevModeData(0 To lngReturn + 100) As Byte
    lngReturn = DocumentProperties(0, lngPrinter, strPrinterName, _
        VarPtr(bytDevModeData(0)), 0, DM_OUT_BUFFER)
    If (lngReturn < 0) Then Err.Raise vbObjectError + 2
    Call CopyMemory(udtDM, bytDevModeData(0), Len(udtDM))
    If udtDM.dmFields And lngPropertyType = 0 Then Err.Raise vbObjectError + 3
    Select Case lngPropertyType
        Case DM_ORIENTATION
            udtDM.dmOrientation = lngPropertyValue
        Case DM_PAPERSIZE
            udtDM.dmPaperSize = lngPropertyValue
        Case DM_PAPERLENGTH
            udtDM.dmPaperLength = lngPropertyValue
        Case DM_PAPERWIDTH
            udtDM.dmPaperWidth = lngPropertyValue
        Case DM_DEFAULTSOURCE
            udtDM.dmDefaultSource = lngPropertyValue
        Case DM_PRINTQUALITY
            udtDM.dmPrintQuality = lngPropertyValue
        Case DM_COLOR
            udtDM.dmColor = lngPropertyValue
        Case DM_DUPLEX
            udtDM.dmDuplex = lngPropertyValue
    End Select
    Call CopyMemory(bytDevModeData(0), udtDM, Len(udtDM))
    lngReturn = DocumentProperties(0, lngPrinter, strPrinterName, _
        VarPtr(bytDevModeData(0)), VarPtr(bytDevModeData(0)), _
        DM_IN_BUFFER Or DM_OUT_BUFFER)
    If (lngReturn < 0) Then Err.Raise vbObjectError + 4
    Call GetPrinter(lngPrinter, 2, 0, 0, lngBytesNeeded)
    If (lngBytesNeeded = 0) Then Err.Raise vbObjectError + 5
    Redim bytPInfoMemory(0 To lngBytesNeeded + 100) As Byte
    lngReturn = GetPrinter(lngPrinter, 2, bytPInfoMemory(0), lngBytesNeeded, lngJunk)
    If (lngReturn = 0) Then Err.Raise vbObjectError + 6
    Call CopyMemory(udtPI, bytPInfoMemory(0), Len(udtPI))
    udtPI.pDevmode = VarPtr(bytDevModeData(0))
    udtPI.pSecurityDescriptor = 0
    Call CopyMemory(bytPInfoMemory(0), udtPI, Len(udtPI))
    lngReturn = SetPrinter(lngPrinter, 2, bytPInfoMemory(0), 0)
    SetPrinterProperty = Cbool(lngReturn)
    err_exit:
    If (lngPrinter <> 0) Then Call ClosePrinter(lngPrinter)
End Function

Private Function GetPrinterProperty(ByVal lngPropertyType As Long) As Long
    Dim udtPD As PRINTER_DEFAULTS
    Dim udtDM As DEVMODE
    Dim strPrinterName As String
    Dim bytDevModeData() As Byte
    Dim lngPrinter As Long, lngReturn As Long
    On Error GoTo err_exit
    strPrinterName = Trim$(Left$(ActivePrinter, _
        InStr(ActivePrinter, " auf ")))
    udtPD.DesiredAccess = PRINTER_NORMAL_ACCESS
    lngReturn = OpenPrinter(strPrinterName, lngPrinter, udtPD)
    If (lngReturn = 0) Or (lngPrinter = 0) Then Exit Function
    lngReturn = DocumentProperties(0, lngPrinter, strPrinterName, 0, 0, 0)
    If (lngReturn < 0) Then Err.Raise vbObjectError + 1
    Redim bytDevModeData(0 To lngReturn + 100) As Byte
    lngReturn = DocumentProperties(0, lngPrinter, strPrinterName, _
        VarPtr(bytDevModeData(0)), 0, DM_OUT_BUFFER)
    If (lngReturn < 0) Then Err.Raise vbObjectError + 2
    Call CopyMemory(udtDM, bytDevModeData(0), Len(udtDM))
    If Not udtDM.dmFields And lngPropertyType = 0 Then Err.Raise vbObjectError + 3
    Select Case lngPropertyType
        Case DM_ORIENTATION
            GetPrinterProperty = udtDM.dmOrientation
        Case DM_PAPERSIZE
            GetPrinterProperty = udtDM.dmPaperSize
        Case DM_PAPERLENGTH
            GetPrinterProperty = udtDM.dmPaperLength
        Case DM_PAPERWIDTH
            GetPrinterProperty = udtDM.dmPaperWidth
        Case DM_DEFAULTSOURCE
            GetPrinterProperty = udtDM.dmDefaultSource
        Case DM_PRINTQUALITY
            GetPrinterProperty = udtDM.dmPrintQuality
        Case DM_COLOR
            GetPrinterProperty = udtDM.dmColor
        Case DM_DUPLEX
            GetPrinterProperty = udtDM.dmDuplex
    End Select
    err_exit:
    If (lngPrinter <> 0) Then Call ClosePrinter(lngPrinter)
End Function

Gruß
Nepumuk

Beliebteste Forumthreads (12 Monate)

4 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread