Hallo,
wenn du "zuverlässig" per VBA die Druck einstellungen ändern willst,
brauchst du die WinAPI.
Call der PrintAPI:
Public Sub PrintOutColor()
On Error GoTo UnableToSetColor
PrintAPI.SetColorMode Application.ActivePrinter, 2
UnableToSetColor:
If Err.Number 0 Then
MsgBox "Ein Fehler beim ändern einer Druckereinstellung ist aufgetreten." & vbCrLf & _
vbCrLf & _
"Fehler ID: " & Err.Number & vbCrLf & _
"Beschreibung: " & Err.Description, vbInformation, "Print Error"
End If
End Sub
PrintAPI Code zum ändern der Druckereinstellungen:
Option Explicit
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
pCompanyLocation As Long
pDevmode As Long ' Pointer to DEVMODE
pSepFile As Long
pPrintProcessor As Long
pDatatype As Long
pParameters As Long
pSecurityDescriptor As Long ' Pointer to SECURITY_DESCRIPTOR
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 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
Private Const Delete = &H10000
Private Const READ_CONTROL = &H20000 ' Allowed to read device information
Private Const WRITE_DAC = &H40000 ' Allowed to write device access control info
Private Const WRITE_OWNER = &H80000 ' Allowed to change the object owner
' Combining these for full access to a device (DELETE + READ_CONTROL + WRITE_DAC + WRITE_OWNER) _
Private Const STANDARD_RIGHTS_REQUIRED = &HF0000
Private Const SERVER_ACCESS_ADMINISTER = &H1 ' Access rights to administer print servers.
Private Const SERVER_ACCESS_ENUMERATE = &H2 ' Access rights to enumerate print servers.
Private Const PRINTER_ACCESS_ADMINISTER = &H4 ' Access rights for printers to perform _
administrative tasks.
Private Const PRINTER_ACCESS_USE = &H8 ' Access rights for printers for general use ( _
printing, querying).
' Access which allows you to set duplex on or off
Private Const PRINTER_NORMAL_ACCESS = (READ_CONTROL Or PRINTER_ACCESS_USE)
Private Const PRINTER_ENUM_CONNECTIONS = &H4
Private Const PRINTER_ENUM_LOCAL = &H2
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 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, _
pPrinter As Byte, ByVal cbBuf As Long, pcbNeeded As Long) As Long
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 Byte, ByVal Command As Long) 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 Long, ByVal cdBuf As Long, pcbNeeded As Long, _
pcReturned As Long) As Long
Private Declare Function PtrToStr Lib "kernel32" Alias "lstrcpyA" _
(ByVal RetVal As String, ByVal Ptr As Long) As Long
Private Declare Function StrLen Lib "kernel32" Alias "lstrlenA" _
(ByVal Ptr As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(pDest As Any, pSource As Any, ByVal cbLength As Long)
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare Function DeviceCapabilities Lib "winspool.drv" _
Alias "DeviceCapabilitiesA" (ByVal lpDeviceName As String, _
ByVal lpPort As String, ByVal iIndex As Long, lpOutput As Any, _
ByVal dev As Long) As Long
#If Win64 Then
Private Declare PtrSafe Function GetProfileString _
Lib "kernel32.dll" Alias "GetProfileStringA" ( _
ByVal lpAppName As String, _
ByVal lpKeyName As String, _
ByVal lpDefault As String, _
ByVal lpReturnedString As String, _
ByVal nSize As Long) _
As Long
#Else
Private Declare Function GetProfileString _
Lib "kernel32.dll" Alias "GetProfileStringA" ( _
ByVal lpAppName As String, _
ByVal lpKeyName As String, _
ByVal lpDefault As String, _
ByVal lpReturnedString As String, _
ByVal nSize As Long) _
As Long
#End If
Public Function PrinterList() As Variant
Dim buffer As String
Dim sOPtr As String
Dim iPos As Integer
Dim lChars As Long
Dim prtList() As String
Dim prtSize As Long
buffer = Space(2048)
lChars = GetProfileString("PrinterPorts", vbNullString, "", buffer, Len(buffer))
If lChars > 0 Then
iPos = InStr(buffer, Chr(0))
While iPos > 1
sOPtr = Left(buffer, iPos - 1)
buffer = Mid(buffer, iPos + 1)
iPos = InStr(buffer, Chr(0))
ReDim Preserve prtList(prtSize)
prtList(prtSize) = sOPtr
prtSize = prtSize + 1
Wend
End If
PrinterList = prtList
End Function
Public Sub SetColorMode(ByVal sPrinterName As String, iColorMode As Long)
SetPrinterProperty sPrinterName, DM_COLOR, iColorMode
End Sub
Public Function GetColorMode(ByVal sPrinterName As String) As Long
GetColorMode = GetPrinterProperty(sPrinterName, DM_COLOR)
End Function
Public Sub SetDuplex(ByVal sPrinterName As String, iDuplex As Long)
SetPrinterProperty sPrinterName, DM_DUPLEX, iDuplex
End Sub
Public Function GetDuplex(ByVal sPrinterName As String) As Long
GetDuplex = GetPrinterProperty(sPrinterName, DM_DUPLEX)
End Function
Public Sub SetPrintQuality(ByVal sPrinterName As String, iQuality As Long)
SetPrinterProperty sPrinterName, DM_PRINTQUALITY, iQuality
End Sub
Public Function GetPrintQuality(ByVal sPrinterName As String) As Long
GetPrintQuality = GetPrinterProperty(sPrinterName, DM_PRINTQUALITY)
End Function
Public Function GetPrintername(ByVal prtName As String) As String
Dim tmp As String
tmp = LTrim(RTrim(Left(prtName, InStr(1, prtName, " auf ", vbTextCompare))))
If tmp = vbNullString Then tmp = prtName
GetPrintername = tmp
End Function
Public Function GetFullPrinterName(ByVal prtName As String) As String
Dim regObj As Object
Dim aTypes As Variant
Dim aDevices As Variant
Dim vDevice As Variant
Dim sValue As String
Dim v As Variant
Dim sLocaleOn As String
Const HKEY_CURRENT_USER = &H80000001
v = Split(Application.ActivePrinter, Space(1))
sLocaleOn = Space(1) & CStr(v(UBound(v) - 1)) & Space(1)
Set regObj = GetObject("WINMGMTS:{impersonationLevel=impersonate}!\\.\root\default: _
StdRegProv")
regObj.EnumValues HKEY_CURRENT_USER, "Software\Microsoft\Windows NT\CurrentVersion\Devices", _
aDevices, aTypes
For Each vDevice In aDevices
regObj.GetStringValue HKEY_CURRENT_USER, "Software\Microsoft\Windows NT\CurrentVersion\ _
Devices", vDevice, sValue
If Left(vDevice, Len(prtName)) = prtName Then
GetFullPrinterName = vDevice & sLocaleOn & Split(sValue, ",")(1)
Exit Function
End If
Next vDevice
GetFullPrinterName = vbNullString
End Function
Public Function PrinterIsUp(ByVal sPrinterName As String) As Boolean
'Code adapted from Microsoft KB article Q230743
Dim hPrinter As Long 'handle for the current printer
Dim pd As PRINTER_DEFAULTS
Dim RetVal As Long
Dim iCount As Long
On Error GoTo cleanup
pd.DesiredAccess = PRINTER_NORMAL_ACCESS
RetVal = OpenPrinter(sPrinterName, hPrinter, pd)
If (RetVal = 0) Or (hPrinter = 0) Then
'Can't access current printer. Bail out doing nothing
Exit Function
End If
cleanup:
'Release the printer handle
If (hPrinter 0) Then Call ClosePrinter(hPrinter)
'Flush the message queue. If you don't do this,
'you can get page fault errors when you try to
'print a document immediately after setting a printer property.
For iCount = 1 To 20
DoEvents
Next iCount
PrinterIsUp = True
End Function
Private Function SetPrinterProperty(ByVal sPrinterName As String, ByVal iPropertyType As Long, _
_
ByVal iPropertyValue As Long) As Boolean
'Code adapted from Microsoft KB article Q230743
Dim hPrinter As Long 'handle for the current printer
Dim pd As PRINTER_DEFAULTS
Dim pinfo As PRINTER_INFO_2
Dim dm As DEVMODE
Dim yDevModeData() As Byte 'Byte array to hold contents
'of DEVMODE structure
Dim yPInfoMemory() As Byte 'Byte array to hold contents
'of PRINTER_INFO_2 structure
Dim iBytesNeeded As Long
Dim RetVal As Long
Dim iJunk As Long
Dim iCount As Long
On Error GoTo cleanup
pd.DesiredAccess = PRINTER_NORMAL_ACCESS
RetVal = OpenPrinter(sPrinterName, hPrinter, pd)
If (RetVal = 0) Or (hPrinter = 0) Then
'Can't access current printer. Bail out doing nothing
Exit Function
End If
'Get the Size of the DEVMODE structure to be loaded
RetVal = DocumentProperties(0, hPrinter, sPrinterName, 0, 0, 0)
If (RetVal 0) Then Call ClosePrinter(hPrinter)
'Flush the message queue. If you don't do this,
'you can get page fault errors when you try to
'print a document immediately after setting a printer property.
For iCount = 1 To 20
DoEvents
Next iCount
End Function
Private Function GetPrinterProperty(ByVal sPrinterName As String, ByVal iPropertyType As Long) _
As Long
'Code adapted from Microsoft KB article Q230743
Dim hPrinter As Long
Dim pd As PRINTER_DEFAULTS
Dim dm As DEVMODE
Dim yDevModeData() As Byte
Dim RetVal As Long
On Error GoTo cleanup
pd.DesiredAccess = PRINTER_NORMAL_ACCESS
'Get the printer handle
RetVal = OpenPrinter(sPrinterName, hPrinter, pd)
If (RetVal = 0) Or (hPrinter = 0) Then
'Couldn't access the printer
Exit Function
End If
'Find out how many bytes needed for the printer properties
RetVal = DocumentProperties(0, hPrinter, sPrinterName, 0, 0, 0)
If (RetVal 0) Then Call ClosePrinter(hPrinter)
End Function