Option Explicit
Option Private Module
' ---------------------------------------------------------
' Funktion ChangeActivePrinter
' Eingestellt von: Andre Schau
' Datum: 5. Juno 2011
' Kommentar: Funktion zur Umstellung des aktiven Drucker
' hier im Beispiel auf PDF, aber es kann jeder
' beliebige Drucker eingestellt werden.
' Parameter: strPrinter
' Rückgabe: Fehlerwert
' siehe API-Argumente
' weitere benoetigte Programme und Funktionen
' API-Funktion: GetProfileString
' Aufruf: Beispiel siehe Sub callChangeActivePrinter()

' Deklarierung der API-Funktion
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 LongAs Long

Sub callChangeActivePrinter()
'Beispiel zur Verwendung der Funktion
'Variablendeklarationen
'Object
Dim objWMIsvc As Object
Dim objPrinter As Object
'Variant
Dim colPrinters
'String
Dim strActPrinter$
'Long
Dim err_number&

'aktiven Drucker ermitteln
strActPrinter = Application.ActivePrinter

'Liste / Collection der verfügbaren Drucker erstellen
Set objWMIsvc = GetObject("winmgmts:\\.\root\cimv2")
Set colPrinters = objWMIsvc.InstancesOf("Win32_Printer")

'PDF-Drucker ermitteln
'Schleife ueber alle Drucker der Liste
For Each objPrinter In colPrinters
  'Wenn im großgeschriebenen Namen PDF, dann
  If InStr(1, UCase(objPrinter.name), "PDF") > 0 Then
    'Hinweis: Bei mehreren PDF-Druckern wird mit "PDF" der
    'erste gewaehlt - alternativ ist eine genauere Namens-
    'angabe noetig!
    'Drucker mit ChangeActivePrinter auf PDF umstellen
    err_number = ChangeActivePrinter(objPrinter.name)
    'Wenn Fehlernummer <> 0 dann
    If err_number <> 0 Then
      'Ausgabe Fehlermeldung
      MsgBox "Fehler: " & err_number & vbLf & Error(err_number)
    'Ende Wenn Fehlernummer <> 0 dann
    End If
    'Ende Schleife ueber alle Drucker der Liste
    Exit For
  'Ende Wenn im großgeschriebenen Namen PDF, dann
  End If
'Nächster Durchgang Schleife ueber alle Drucker der Liste
Next
'Drucker auf vorherigen Drucker zuruecksetzen
'Application.ActivePrinter = strActPrinter
End Sub

Function ChangeActivePrinter(strPrinter As StringAs Long
'Konstantendeklaration
Const loBUFFsize As Long = 1024
'Variablendeklaration
'String
Dim strBUFF As String * loBUFFsize
'Rueckgabewert auf 0 setzen
ChangeActivePrinter = 0
'Druckerinformationen auslesen
GetProfileString "PrinterPorts", strPrinter, "", strBUFF, Len(strBUFF)
'Aktiven Drucker setzen
Application.ActivePrinter = strPrinter & " auf " & Split(strBUFF, ",")(1)
'Wenn Fehler dann Rueckgabewert = Fehlernummer
If Err.Number <> 0 Then ChangeActivePrinter = Err.Number
End Function