Hallo,
dies war kürzlich eine Frage, daher habe ich einen Code dafür zur Hand.
Option Explicit
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 _
lpReserved 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 KEY_ENUMERATE_SUB_KEYS = &H8
Private Const KEY_NOTIFY = &H10
Private Const KEY_QUERY_VALUE = &H1
Private Const READ_CONTROL = &H20000
Private Const KEY_READ = (READ_CONTROL Or KEY_QUERY_VALUE Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY)
Private Const HKEY_CURRENT_USER = &H80000001
Private Const Schlüsselname = "Software\Microsoft\Windows NT\CurrentVersion\Devices\"
Private Function FindDrucker(ByVal sDruckerName$) As String
Dim dummy, hwndSchlüssel&
Dim Länge&, lngIndex&
Dim strFeld As String, lngLänge As Long
Dim arrPuffer() As Byte, strPuffer As String
Dim lngArrLänge As Long, lngPortlänge As Long
Dim Drucker As String
dummy = RegOpenKeyEx(HKEY_CURRENT_USER, _
Schlüsselname, 0&, KEY_READ, hwndSchlüssel)
If dummy <> 0 Then MsgBox "Falscher Schlüssel": Exit Function
strFeld = String(1024, 0)
lngLänge = 1023
Redim arrPuffer(0 To 1000)
Do While RegEnumValue(hwndSchlüssel, lngIndex, _
strFeld, lngLänge, 0&, ByVal 0&, ByVal 0&, ByVal 0&) = 0
Drucker = Left$(strFeld, lngLänge) & " auf "
lngArrLänge = 1024
RegEnumValue hwndSchlüssel, lngIndex, strFeld, _
lngLänge, 0&, 0&, arrPuffer(0), lngArrLänge
strPuffer = (StrConv(arrPuffer, vbUnicode))
lngPortlänge = InStr(1, strPuffer, ":") - InStr(1, strPuffer, ",")
strPuffer = Mid$(strPuffer, InStr(1, strPuffer, ":") - 4, lngPortlänge)
strPuffer = Replace(strPuffer, ",", "")
strPuffer = IIf(Right$(strPuffer, 1) = ":", strPuffer, strPuffer & ":")
Drucker = Drucker & strPuffer
If Drucker Like sDruckerName Then FindDrucker = Drucker: Exit Do
lngIndex = lngIndex + 1
strFeld = String(1024, 0)
lngLänge = 1023
Loop
dummy = RegCloseKey(hwndSchlüssel)
End Function
Sub TestDruckerUmstellen()
Dim sAktuellerDrucker As String
Dim sDrucker As String
'aktuellen Drucker in einem String merken
sAktuellerDrucker = Application.ActivePrinter
'Drucker Suchen, Platzhalter verwenden
sDrucker = FindDrucker("*PDF*")
If sDrucker <> "" Then
Application.ActivePrinter = sDrucker
End If
'hier Dein Code für den Ausdruck
'...
'...
'Drucker wieder zurückstellen, sollte er umgestellt sein
If sDrucker <> "" Then
Application.ActivePrinter = sAktuellerDrucker
End If
End Sub
Gruß Tino