AW: Farbig/SW Druck per Button
10.11.2016 10:51:24
Michael
Hallo Gunter,
ich hatte ein ähnliches Problem; dazu musste ich die IP-Anschrift des Farbdruckers in den Code einbinden.
Zum Auslesen welcher Drucker welche IP-Anschrift oder welchen Namen hat, ist folgender Code sehr gut (Ergebnis wird im Fenster Direktbereich angezeigt):
Sub ListAllPrinters()
Dim WshNetwork As Object, oPrinters As Object, i%
Set WshNetwork = CreateObject("WScript.Network")
Set oPrinters = WshNetwork.EnumPrinterConnections
For i = 0 To oPrinters.Count - 1 Step 2
Debug.Print oPrinters.Item(i + 1) & " an " & oPrinters.Item(i)
Next
Set WshNetwork = Nothing
End Sub
Für den Ausdruck auf den Farbdrucker benutze ich dann folgenden Code (hier wurde mir in einem anderen Forum sehr gut geholfen):
Public Function GetPrinterName(sIPAdress As String) As String
Const HKEY_current_user = &H80000001
Dim oReg As Object, i As Long
Dim strKeyPath As String, strValue As String
Dim arrPrinter As Variant
Dim oWSN As Object
Dim oPrinter As Object
Dim sPrinterName As String
Dim sResult As String
Set oWSN = CreateObject("WScript.Network")
Set oPrinter = oWSN.EnumPrinterConnections
For i = 0 To oPrinter.Count - 1 Step 2
If oPrinter.Item(i) = sIPAdress Then
sPrinterName = oPrinter.Item(i + 1)
Exit For
End If
Next
If sPrinterName = "" Then Exit Function
Set oReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\default:StdRegProv" _
)
strKeyPath = "Software\Microsoft\Windows NT\CurrentVersion\Devices"
oReg.EnumValues HKEY_current_user, strKeyPath, arrPrinter
For i = 0 To UBound(arrPrinter)
If arrPrinter(i) = sPrinterName Then
oReg.GetStringValue HKEY_current_user, strKeyPath, arrPrinter(i), sResult
sResult = arrPrinter(i) & Replace(sResult, "winspool,", " auf ")
Exit For
End If
Next
GetPrinterName = sResult
Set oReg = Nothing
End Function
Sub Farbdruck()
Dim sOldPrinter As String
Dim sNewPrinter As String
sOldPrinter = Application.ActivePrinter
sNewPrinter = GetPrinterName("5.4.5.194")
If Not sNewPrinter = "" Then
Application.ActivePrinter = sNewPrinter
'Hier wird dann entsprechend gedruckt
Worksheets("Testseite").PrintOut
'Zurückstellen auf Standarddrucker
Application.ActivePrinter = sOldPrinter
Else
MsgBox ("Achtung! Dieser Drucker existiert nicht!")
End If
Sheets("Daten").Select
End Sub
Vielleicht kannst du damit was anfangen.
Gruß
Michael