Druckereinstellungen ändern

Druckereinstellungen ändern

Beispieldatei (Druckeraenderungen.zip 92 kB)

VBA kennt leider kein Printer-Objekt, welches Zugriff auf die verschiedenen Eigenschaften eines Druckers während der Programmausführung bietet.

Es ist mit ein paar API-Funktionen aber möglich, die Einstellungen eines Druckers zu ändern. Das geschieht leider dauerhaft, bei NT und XP für den jeweiligen Benutzer. Da das ungefragte Ändern kein guter Stil ist, sollte man vorher nachfragen und darauf achten, die Eigenschaften, die geändert werden sollen, vorher zu sichern und nachher wiederherzustellen!

Leider hat sich mittlerweile herausgestellt, dass Excel diese am Drucker gesetzten Einstellungen nicht übernimmt!

Nach einer Rückfrage per Mail im September 09 bin ich der Sache mal auf den Grund gegangen.

Erst einmal hatte ich im Internet recherchiert, aber keine weiterführenden Informationen gefunden. Der eindeutige Tenor von Excelanern war der, dass es niemals ohne SendKeys oder einem anderen, auf die Wünsche angepassten Drucker funktioniert. Da ich mich aber nicht so schnell geschlagen gebe, habe ich das Programm Procmon mitlaufen lassen, welches Datei- und Registryeinträge protokolliert.

Es ist natürlich schon heftig, was dabei innerhalb von Sekunden an Informationen zusammenkommt, ich habe mich deshalb auf die Schreibzugriffe von Excel in die Registry und in Dateien beschränkt. Anschließend habe ich aus Excel heraus die aktuellen Druckereinstellungen geändert und mir die Einträge angesehen. Nachdem ich allen möglichen Spuren gefolgt bin, kam ich zu dem Schluss, dass diese Informationen weder in der Registry, noch in einer Ini-Datei abgelegt werden. Da Änderungen für ein Dokument aber dauerhaft waren, habe ich mich mit der Excel-Datei, also dem Dokument selbst befasst. Glücklicherweise sind die "Dateien" von Excel 2007 gezippte Archive, deshalb musste ich keinen Biff-Viewer bemühen.

Man erkennt, wenn man die Dateiendung auf .zip ändert und anschließend entzippt, dass dort eine Bin-Datei existiert, welche die aktuellen Einstellungen enthält. Der Inhalt scheint eine DevMode-Struktur zu sein. Es ist natürlich nicht möglich, im laufenden Betrieb an der gerade geöffneten Datei Operationen am offenen Herz durchzuführen, um diese Datei direkt zu ändern.

Nach einigen Tests bin ich aber dahintergekommen, dass es eine recht einfache Methode gibt, diese ganze Problematik zu umgehen. Die Lösung ist so einfach, dass man sich fast schämt, nicht gleich darauf gekommen zu sein:

Dieser Würgaround macht sich die Tatsache zunutze, dass die Defaulteinstellungen eines Druckers neu ausgelesen werden, wenn man von einem anderen Drucker zu diesem wechselt. Man muss also nichts weiter tun, als den gerade eingestellten Drucker zu wechseln (ActivePrinter), die Einstellungen zu ändern und wieder zu dem ursprünglichen Drucker zu wechseln. Voraussetzung sind also mindestens zwei installierte Drucke, wobei der eine aber gar nicht physikalisch existieren muss. Dieser Dummydrucker sollte, wenn er physikalisch nicht existiert, im Druckmanager so eingestellt sein, dass er offline verwendbar ist .

Es ist natürlich schwierig, immer einen freien Drucker auszusuchen und diesen hartcodiert im VBA-Code unterzubringen. Auf einem anderen Rechner können andere Drucker verfügbar sein, oder die Portnummer stimmt nicht mehr überein. Deshalb lese ich nun aktuell alle vorhandenen Drucker mitsamt der Portnummer aus der Registry aus und wähle den ersten, nicht identischen Drucker aus, zu dem dann gewechselt wird.

Der Name des vorher für das Dokument eingestellen Druckers wird in einer Variablen gespeichert, damit man diesen Ändern und anschließend wieder zum aktiven Drucker machen kann. Selbstverständlich bleiben Einstellungen des Dokuments wie Papiergröße und Quer- oder Hochformat erhalten, eine Änderung der Druckereinstellungen bringt in dieser Beziehung also gar nichts.

Implementiert habe ich drei Prozeduren, mit der man den Schacht, die Eigenschaft Duplex und die Druckqualität festlegen kann. Die Longwerte, die man optional als neue Einstellung an diese Prozeduren übergeben kann, sind zum Teil von den Möglichkeiten des Druckers abhängig, es sind bei der Festlegung der Druckqualität und der Eigenschaft Duplex lediglich wenige Werte möglich. Welche das sind, kann man im Code erkennen.

Die drei Prozeduren können als zweiten Parameter einen Wahrheitswert übernehmen. Ist dieser gesetzt, werden in einer Messagebox die gerade eingestellten Werte ausgegeben. Um herauszufinden, welche Druckerschächte welchen Wert haben, kann man den gewünschten einstellen und die Prozeduren mit dem auf Wahr gesetzten zweiten Parameter aufzurufen. Der erste ist auch optional und kann dabei weggelassen werden.

Folgendermaßen werden die Prozeduren benutzt:

Option Explicit

Private Sub cmdDuplex_Click()
   Call SetDuplex(DuplexZeigen:=True)
End Sub
Private Sub cmdChangeDuplex_Click()
   Dim varRet  As Variant
   varRet = Application.InputBox( _
      "Nummer für Duplex eingeben" & _
      "(1=SIMPLEX, 2=VERTICAL, 3=HORIZONTAL)", "Duplex", 1, , , , , 1)
   If varRet = False Then Exit Sub
   Call SetDuplex(Duplex:=CLng(varRet))
End Sub

Private Sub cmdPaperbin_Click()
   Call SetPaperBins(AktiveZufuhrZeigen:=True)
End Sub
Private Sub cmdChangePaperbin_Click()
   Dim varRet  As Variant
   varRet = Application.InputBox( _
      "Nummer für Schacht eingeben", "Papierzufuhr", 1, , , , , 1)
   If varRet = False Then Exit Sub
   Call SetPaperBins(Papierzufuhr:=CLng(varRet))
End Sub

Private Sub cmdQuality_Click()
   Call SetDruckQualitaet(QualitaetZeigen:=True)
End Sub
Private Sub cmdChangeQuality_Click()
   Dim varRet  As Variant
   varRet = Application.InputBox( _
      "Nummer für Qualität eingeben " & _
      "(-1 für Schnell, bis -4 für Hoch)", "Qualität", -3, , , , , 1)
   If varRet = False Then Exit Sub
   Call SetDruckQualitaet(Qualitaet:=CLng(varRet))
End Sub

Hier der eigentliche Code:

Option Explicit
Private Const CCHDEVICENAME As Long =  32
Private Const CCHFORMNAME As Long =  32
Private Const DM_IN_BUFFER As Long =  8
Private Const DM_IN_PROMPT As Long =  4
Private Const DM_OUT_BUFFER As Long =  2
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 Const STANDARD_RIGHTS_REQUIRED = &HF0000
Private Const PRINTER_ACCESS_ADMINISTER = &H4
Private Const PRINTER_ACCESS_USE = &H8
Private Const PRINTER_ALL_ACCESS = _
   (STANDARD_RIGHTS_REQUIRED Or _
   PRINTER_ACCESS_ADMINISTER Or _
   PRINTER_ACCESS_USE)
Private Type PRINTER_DEFAULTS
   pDatatype As String
   pDevMode As Long 'DEVMODE
   DesiredAccess As Long
End Type
Private Declare Function OpenPrinter _
   Lib "winspool.drv" Alias "OpenPrinterA" ( _
   ByVal pstrPrinter As String, _
   phPrinter As Long, _
   pDefault As PRINTER_DEFAULTS _
   ) As Long
Private Declare Function ClosePrinter _
   Lib "winspool.drv" ( _
   ByVal hPrinter As Long _
   ) As Long
Private Declare Function GetPrinter _
   Lib "winspool.drv" Alias "GetPrinterA" ( _
   ByVal hPrinter As Long, _
   ByVal Level As Long, _
   pPrinter As Any, _
   ByVal cbBuf As Long, _
   pcblngLänge As Long _
   ) As Long
Private Declare Function SetPrinter _
   Lib "winspool.drv" Alias "SetPrinterA" ( _
   ByVal hPrinter As Long, _
   ByVal Level As Long, _
   pPrinter As Any, _
   ByVal Command As Long _
   ) As Long
Private Declare Sub CopyMemory _
   Lib "kernel32" Alias "RtlMoveMemory" ( _
   Destination As Any, _
   Source As Any, _
   ByVal Length As Long)
Private Declare Function DocumentProperties _
   Lib "winspool.drv" Alias "DocumentPropertiesA" ( _
   ByVal hwnd As Long, _
   ByVal hPrinter As Long, _
   ByVal pDeviceName As String, _
   pDevModeOutput As Any, _
   pDevModeInput As Any, _
   ByVal fMode As Long _
   ) As Long
Private Declare Function SendMessage _
   Lib "user32" Alias "SendMessageA" ( _
   ByVal hwnd As Long, _
   ByVal wMsg As Long, _
   ByVal wParam As Long, _
   lParam As Any _
   ) As Long
Private Declare Function RegEnumValue _
   Lib "advapi32.dll" Alias "RegEnumValueA" ( _
   ByVal hKey As Long, _
   ByVal dwIndex As Long, _
   ByVal lpValueName As String, _
   lpcbValueName As Long, _
   ByVal lngPtreserved As Long, _
   lpType As Long, _
   lpData As Byte, _
   lpcbData As Long _
   ) As Long
Private Declare Function RegOpenKeyEx _
   Lib "advapi32.dll" Alias "RegOpenKeyExA" ( _
   ByVal hKey As Long, _
   ByVal lpSubKey As String, _
   ByVal ulOptions As Long, _
   ByVal samDesired As Long, _
   phkResult As Long _
   ) As Long
Private Declare Function RegCloseKey _
   Lib "advapi32.dll" ( _
   ByVal hKey As Long _
   ) As Long

Private Const DM_COPIES                As Long = &H100&
Private Const DM_DEFAULTSOURCE         As Long = &H200&
Private Const DM_COLLATE               As Long = &H8000
Private Const DM_COLOR                 As Long = &H800&
Private Const DM_DITHERTYPE            As Long = &H10000000
Private Const DM_DUPLEX                As Long = &H1000&
Private Const DM_FORMNAME              As Long = &H10000
Private Const DM_GRAYSCALE             As Long = &H1
Private Const DM_ICMINTENT             As Long = &H4000000
Private Const DM_ICMMETHOD             As Long = &H2000000
Private Const DM_INTERLACED            As Long = &H2
Private Const DM_MEDIATYPE             As Long = &H8000000
Private Const DM_MODIFY                As Long = 8
Private Const DM_ORIENTATION           As Long = &H1&
Private Const DM_PAPERLENGTH           As Long = &H4&
Private Const DM_PAPERSIZE             As Long = &H2&
Private Const DM_PAPERWIDTH            As Long = &H8&
Private Const DM_PRINTQUALITY          As Long = &H400&
Private Const DM_PROMPT                As Long = 4
Private Const DM_RESERVED1             As Long = &H800000
Private Const DM_SCALE                 As Long = &H10&
Private Const DM_SPECVERSION           As Long = &H320
Private Const DM_TTOPTION              As Long = &H4000&
Private Const DM_UPDATE                As Long = 1
Private Const DM_YRESOLUTION           As Long = &H2000&

Private Const DMRES_DRAFT              As Long = (-1)
Private Const DMRES_HIGH               As Long = (-4)
Private Const DMRES_LOW                As Long = (-2)
Private Const DMRES_MEDIUM             As Long = (-3)

Private Const DMDUP_HORIZONTAL         As Long = 3
Private Const DMDUP_SIMPLEX            As Long = 1
Private Const DMDUP_VERTICAL           As Long = 2

Private Const DMBIN_MANUAL             As Long = 4
Private Const DMBIN_MIDDLE             As Long = 3
Private Const DMBIN_UPPER              As Long = 1
Private Const DMBIN_ENVMANUAL          As Long = 6
Private Const DMBIN_AUTO               As Long = 7
Private Const DMBIN_CASSETTE           As Long = 14
Private Const DMBIN_ENVELOPE           As Long = 5
Private Const DMBIN_LARGECAPACITY      As Long = 11
Private Const DMBIN_LARGEFMT           As Long = 10
Private Const DMBIN_LOWER              As Long = 2
Private Const DMBIN_ONLYONE            As Long = 1
Private Const DMBIN_SMALLFMT           As Long = 9
Private Const DMBIN_TRACTOR            As Long = 8

Private Const DMMEDIA_GLOSSY           As Long = 2
Private Const DMMEDIA_STANDARD         As Long = 1
Private Const DMMEDIA_TRANSPARENCY     As Long = 3

Private Const HWND_BROADCAST           As Long = &HFFFF&
Private Const WM_DEVMODECHANGE         As Long = &H1B

Private Const KEY_ENUMERATE_SUB_KEYS   As Long = &H8
Private Const KEY_NOTIFY               As Long = &H10
Private Const KEY_QUERY_VALUE          As Long = &H1
Private Const READ_CONTROL             As Long = &H20000
Private Const KEY_READ                 As Long = ( _
   READ_CONTROL Or KEY_QUERY_VALUE Or _
   KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY)

Private Const HKEY_CURRENT_USER        As Long = &H80000001
Private Const constKeyName             As String = _
    "Software\Microsoft\Windows NT\CurrentVersion\Devices\"

Public Sub SetPaperBins( _
   Optional Papierzufuhr As Long = -1, _
   Optional AktiveZufuhrZeigen As Boolean)
   Dim arrBuffer()         As Long
   Dim lngLänge            As Long
   Dim lngRück             As Long
   Dim udtDevMode          As DEVMODE
   Dim udtPrintDef         As PRINTER_DEFAULTS
   Dim lngRet              As Long
   Dim lngPtrDevMode       As Long
   Dim lngPrinter          As Long
   Dim strPrinter          As String
   Dim strDefault          As String
   Dim varPrinterList      As Variant
   Dim varPrinter          As Variant
   Dim dteTimeout          As Date
   On Error Resume Next

   strDefault = Application.ActivePrinter

   strPrinter = Split(strDefault, " auf ")(0)

   ' Printer-Defaults-Struktur initialisieren
   udtPrintDef.pDatatype = vbNullString
   udtPrintDef.pDevMode = 0
   udtPrintDef.DesiredAccess = PRINTER_ALL_ACCESS

   ' Printer öffnen
   lngRet = OpenPrinter(strPrinter, lngPrinter, udtPrintDef)

   ' Pufferlänge ermitteln
   lngRet = GetPrinter(lngPrinter, 2, ByVal 0&, 0, lngLänge)

   ' Puffer anpassen
   ReDim arrBuffer((lngLänge \ 4))

   ' Printerinfos ermitteln (Level 2)
   lngRet = GetPrinter(lngPrinter, 2, _
      arrBuffer(0), lngLänge, lngLänge)

   ' Pointer auf die DEVMODE-Struktur
   lngPtrDevMode = arrBuffer(7)

   ' Eigene DEVMODE-Struktur füllen
   CopyMemory udtDevMode, ByVal lngPtrDevMode, Len(udtDevMode)

   With udtDevMode

      If AktiveZufuhrZeigen Then
         MsgBox "Aktueller Schacht = " & .dmDefaultSource, , _
            strDefault
      End If

      If Papierzufuhr <> -1 Then

         varPrinterList = Printerlist

         For Each varPrinter In varPrinterList

            If InStr(1, varPrinter, strPrinter) = 0 Then
               Err.Clear
               ' Kurzzeitig einen anderen Drucker als den aktiven
               ' Drucker einstellen. Am besten ein anderer Typ!
               Application.ActivePrinter = varPrinter

               If Err.Number = 0 Then Exit For

            End If
         Next

         DoEvents

         If Application.ActivePrinter = strDefault Then

            MsgBox "Temporäre Umstellung auf einen anderen " & _
               "Drucker momentan nicht möglich!"

            ' Drucker schließen
            lngRet = ClosePrinter(lngPrinter)

            Exit Sub

         End If

         .dmDefaultSource = Papierzufuhr

         .dmFields = udtDevMode.dmFields Or DM_DEFAULTSOURCE

         ' Änderungen zurück an die ursprüngliche Speicherstelle
         CopyMemory ByVal lngPtrDevMode, udtDevMode, Len(udtDevMode)

         ' Druckereinstellungen ändern
         lngRet = DocumentProperties( _
            0, lngPrinter, strPrinter, ByVal lngPtrDevMode, _
            ByVal lngPtrDevMode, DM_IN_BUFFER Or DM_OUT_BUFFER)
         lngRet = SetPrinter(lngPrinter, 2, arrBuffer(0), 0)

         ' Anwendungen über die Änderungen informieren
         lngRet = SendMessage(HWND_BROADCAST, WM_DEVMODECHANGE, _
            0, strPrinter)

         ' Drucker schließen
         lngRet = ClosePrinter(lngPrinter)

         dteTimeout = Now + TimeSerial(0, 0, 10)

         Application.ActivePrinter = strDefault

         DoEvents

      Else

         ' Drucker schließen
         lngRet = ClosePrinter(lngPrinter)

      End If

   End With

End Sub

Public Sub SetDuplex( _
   Optional Duplex As Long = -1, _
   Optional DuplexZeigen As Boolean)
   Dim arrBuffer()         As Long
   Dim lngLänge            As Long
   Dim lngRück             As Long
   Dim udtDevMode          As DEVMODE
   Dim udtPrintDef         As PRINTER_DEFAULTS
   Dim lngRet              As Long
   Dim lngPtrDevMode       As Long
   Dim lngPrinter          As Long
   Dim strPrinter          As String
   Dim strDefault          As String
   Dim varPrinterList      As Variant
   Dim varPrinter          As Variant
   Dim dteTimeout          As Date
   On Error Resume Next

   strDefault = Application.ActivePrinter

   strPrinter = Split(strDefault, " auf ")(0)

   ' Printer-Defaults-Struktur initialisieren
   udtPrintDef.pDatatype = vbNullString
   udtPrintDef.pDevMode = 0
   udtPrintDef.DesiredAccess = PRINTER_ALL_ACCESS

   ' Printer öffnen
   lngRet = OpenPrinter(strPrinter, lngPrinter, udtPrintDef)

   ' Pufferlänge ermitteln
   lngRet = GetPrinter(lngPrinter, 2, ByVal 0&, 0, lngLänge)

   ' Puffer anpassen
   ReDim arrBuffer((lngLänge \ 4))

   ' Printerinfos ermitteln (Level 2)
   lngRet = GetPrinter(lngPrinter, 2, _
      arrBuffer(0), lngLänge, lngLänge)

   ' Pointer auf die DEVMODE-Struktur
   lngPtrDevMode = arrBuffer(7)

   ' Eigene DEVMODE-Struktur füllen
   CopyMemory udtDevMode, ByVal lngPtrDevMode, Len(udtDevMode)

   With udtDevMode

      If DuplexZeigen Then
         MsgBox "Aktueller Duplex = " & .dmDuplex, , _
            strDefault
      End If

      If Duplex <> -1 Then

         varPrinterList = Printerlist

         For Each varPrinter In varPrinterList

            If InStr(1, varPrinter, strPrinter) = 0 Then
               Err.Clear
               ' Kurzzeitig einen anderen Drucker als den aktiven
               ' Drucker einstellen. Am besten ein anderer Typ!
               Application.ActivePrinter = varPrinter

               If Err.Number = 0 Then Exit For

            End If
         Next

         DoEvents

         If Application.ActivePrinter = strDefault Then

            MsgBox "Temporäre Umstellung auf einen anderen " & _
               "Drucker momentan nicht möglich!"

            ' Drucker schließen
            lngRet = ClosePrinter(lngPrinter)

            Exit Sub

         End If

         If (Duplex < 1) Or (Duplex > 3) Then
            Duplex = DMDUP_SIMPLEX
         End If

         .dmDuplex = Duplex

         .dmFields = udtDevMode.dmFields Or DM_DUPLEX

         ' Änderungen zurück an die ursprüngliche Speicherstelle
         CopyMemory ByVal lngPtrDevMode, udtDevMode, Len(udtDevMode)

         ' Druckereinstellungen ändern
         lngRet = DocumentProperties( _
            0, lngPrinter, strPrinter, ByVal lngPtrDevMode, _
            ByVal lngPtrDevMode, DM_IN_BUFFER Or DM_OUT_BUFFER)
         lngRet = SetPrinter(lngPrinter, 2, arrBuffer(0), 0)

         ' Anwendungen über die Änderungen informieren
         lngRet = SendMessage(HWND_BROADCAST, WM_DEVMODECHANGE, _
            0, strPrinter)

         ' Drucker schließen
         lngRet = ClosePrinter(lngPrinter)

         dteTimeout = Now + TimeSerial(0, 0, 10)

         Application.ActivePrinter = strDefault

         DoEvents

      Else

         ' Drucker schließen
         lngRet = ClosePrinter(lngPrinter)

      End If

   End With

End Sub

Public Sub SetDruckQualitaet( _
   Optional Qualitaet As Long = 0, _
   Optional QualitaetZeigen As Boolean)
   Dim arrBuffer()         As Long
   Dim lngLänge            As Long
   Dim lngRück             As Long
   Dim udtDevMode          As DEVMODE
   Dim udtPrintDef         As PRINTER_DEFAULTS
   Dim lngRet              As Long
   Dim lngPtrDevMode       As Long
   Dim lngPrinter          As Long
   Dim strPrinter          As String
   Dim strDefault          As String
   Dim varPrinterList      As Variant
   Dim varPrinter          As Variant
   Dim dteTimeout          As Date
   On Error Resume Next

   strDefault = Application.ActivePrinter

   strPrinter = Split(strDefault, " auf ")(0)

   ' Printer-Defaults-Struktur initialisieren
   udtPrintDef.pDatatype = vbNullString
   udtPrintDef.pDevMode = 0
   udtPrintDef.DesiredAccess = PRINTER_ALL_ACCESS

   ' Printer öffnen
   lngRet = OpenPrinter(strPrinter, lngPrinter, udtPrintDef)

   ' Pufferlänge ermitteln
   lngRet = GetPrinter(lngPrinter, 2, ByVal 0&, 0, lngLänge)

   ' Puffer anpassen
   ReDim arrBuffer((lngLänge \ 4))

   ' Printerinfos ermitteln (Level 2)
   lngRet = GetPrinter(lngPrinter, 2, _
      arrBuffer(0), lngLänge, lngLänge)

   ' Pointer auf die DEVMODE-Struktur
   lngPtrDevMode = arrBuffer(7)

   ' Eigene DEVMODE-Struktur füllen
   CopyMemory udtDevMode, ByVal lngPtrDevMode, Len(udtDevMode)

   With udtDevMode

      If QualitaetZeigen Then
         MsgBox "Aktuelle Qualität = " & .dmPrintQuality, , _
            strDefault
      End If

      If Qualitaet <> 0 Then

         varPrinterList = Printerlist

         For Each varPrinter In varPrinterList

            If InStr(1, varPrinter, strPrinter) = 0 Then
               Err.Clear
               ' Kurzzeitig einen anderen Drucker als den aktiven
               ' Drucker einstellen. Am besten ein anderer Typ!
               Application.ActivePrinter = varPrinter

               If Err.Number = 0 Then Exit For

            End If
         Next

         DoEvents

         If Application.ActivePrinter = strDefault Then

            MsgBox "Temporäre Umstellung auf einen anderen " & _
               "Drucker momentan nicht möglich!"

            ' Drucker schließen
            lngRet = ClosePrinter(lngPrinter)

            Exit Sub

         End If

         If (Qualitaet < -4) Or (Qualitaet >= 0) Then
            Qualitaet = DMRES_MEDIUM
         End If

         .dmPrintQuality = Qualitaet

         .dmFields = udtDevMode.dmFields Or DM_PRINTQUALITY

         ' Änderungen zurück an die ursprüngliche Speicherstelle
         CopyMemory ByVal lngPtrDevMode, udtDevMode, Len(udtDevMode)

         ' Druckereinstellungen ändern
         lngRet = DocumentProperties( _
            0, lngPrinter, strPrinter, ByVal lngPtrDevMode, _
            ByVal lngPtrDevMode, DM_IN_BUFFER Or DM_OUT_BUFFER)
         lngRet = SetPrinter(lngPrinter, 2, arrBuffer(0), 0)

         ' Anwendungen über die Änderungen informieren
         lngRet = SendMessage(HWND_BROADCAST, WM_DEVMODECHANGE, _
            0, strPrinter)

         ' Drucker schließen
         lngRet = ClosePrinter(lngPrinter)

         dteTimeout = Now + TimeSerial(0, 0, 10)

         Application.ActivePrinter = strDefault

         DoEvents

      Else

         ' Drucker schließen
         lngRet = ClosePrinter(lngPrinter)

      End If

   End With

End Sub

Private Function Printerlist()
   Dim lngDummy      As Long
   Dim lngKeyHandle  As Long
   Dim lngIndex      As Long
   Dim lngPortLen    As Long
   Dim strField      As String
   Dim lngBuffLen    As Long
   Dim strBuffer     As String
   Dim lngArrBuffLen As Long
   Dim abytBuffer()  As Byte
   Dim astrPrinter() As String
   ReDim astrPrinter(1 To 500)

   'Schlüssel öffnen
   lngDummy = RegOpenKeyEx(HKEY_CURRENT_USER, _
      constKeyName, 0&, KEY_READ, lngKeyHandle)

   If lngDummy <> 0 Then MsgBox "Falscher Schlüssel": Exit Function

   'Puffer für den Wertnamen erzeugen
   strField = String(1024, 0)
   lngBuffLen = 1023 'Länge Puffer Wertname

   'Puffer für den Wert erzeugen
   ReDim abytBuffer(0 To 1024)
   lngArrBuffLen = 1024 'Länge Puffer Wert

   Do While RegEnumValue( _
      lngKeyHandle, lngIndex, strField, _
      lngBuffLen, 0&, ByVal 0&, _
      abytBuffer(0), lngArrBuffLen _
      ) = 0

      'Bytearray in einen Unicodestring umwandeln
      strBuffer = (StrConv(abytBuffer, vbUnicode))

      'Den String ab dem Komma bis einschließlich
      'dem Doppelpunkt extrahieren
      'strBuffer ist beispielsweise "winspool,LPT1: "
      lngPortLen = InStr(1, strBuffer, ":") - _
          InStr(1, strBuffer, ",")
      strBuffer = Mid$(strBuffer, InStr(1, strBuffer, ":") _
          - 4, lngPortLen)

      'Druckerstring zusammensetzen
      'strField ist beispielsweise "HP DesignJet 800 42 by HP"
      astrPrinter(lngIndex + 1) = Left$(strField, lngBuffLen) & _
          " auf " & strBuffer

      lngIndex = lngIndex + 1

      lngArrBuffLen = 1024 'Länge Puffer Wert

      'Puffer für den Wertnamen erzeugen
      strField = String(1024, 0)
      lngBuffLen = 1023 'Länge Puffer Wertname

   Loop 'Nächster Drucker

   ReDim Preserve astrPrinter(1 To lngIndex)

   lngDummy = RegCloseKey(lngKeyHandle)

   Printerlist = astrPrinter

End Function