Vorhandensein eines Farbdruckers prüfen

Vorhandensein eines Farbdruckers prüfen: CreatelCA, DeleteDC, GetDeviceCaps, RegOpenKeyExA
Declare Function CreateICA Lib "GDI32" (ByVal driver As String, ByVal _
device As String, ByVal Port As String, devmode As Long) As Long
Declare Function DeleteDC Lib "GDI32" (ByVal hdc As Long) As Boolean
Declare Function GetDeviceCaps Lib "GDI32" (ByVal hdc As Long, ByVal cap As Integer) As Integer
Declare Function RegOpenKeyExA Lib "advapi32" (ByVal hkey As Long, ByVal _
subkey As String, ByVal options As Long, ByVal access As Long, ByRef newkey As Long) As Long
Declare Function RegCloseKey Lib "advapi32" (ByVal hkey As Long) As Long
Declare Function RegQueryValueExA Lib "advapi32" (ByVal hkey As Long, _
ByVal entry As String, ByRef reserved As Long, ByRef dtype As Long, _
ByVal retval As String, ByRef datalen As Long) As Long
Sub Demo()
MsgBox IsColourPrinter, , "Colour Printer?"
End Sub
Function IsColourPrinter() As Boolean Wrapper for GetPrinterColours function returns TRUE if
IsColourPrinter = GetPrinterColours > 2 a colour printer,
End Function returns FALSE if not colour or an error occurred.
Function GetPrinterColours() As Integer Obtain the number of colours active printer is capable of
GetPrinterColours = 0 printing 2 colours (or less?) indicates mono printer
On Error GoTo errortrap a return value of zero indicates an error return value
Dim PrinterName As String
Dim DriverName As String
Dim DriverFile As String
Dim Port As String
Dim newkey, datalen As Long
Dim OnLocation, tempval As Integer
Dim hdc As Long
hdc = 0
Const HKEY_LOCAL_MACHINE = &H80000002 constants for registry functions
Const ERROR_NONE = 0
Const REG_SZ As Long = 1
Const NUMCOLORS = 24 constant for device capability function
PrinterName = Application.ActivePrinter get active printer name
OnLocation = 0 extract printer device name by getting last occurrence of on
Do
tempval = InStr(OnLocation + 1, PrinterName, " on ")
If tempval > 0 Then
OnLocation = tempval
End If
Loop While tempval > 0
PrinterName = Left(PrinterName, OnLocation - 1)
If Not GetRegistryEntry(HKEY_LOCAL_MACHINE, _ get printer driver name from registry
"System\CurrentControlSet\Control\Print\Printers\" & PrinterName, _
"Printer Driver", DriverName) Then
Exit Function
End If
If Not GetRegistryEntry(HKEY_LOCAL_MACHINE, _ get printer port from registry
"System\CurrentControlSet\Control\Print\Printers\" & PrinterName, _
"Port", Port) Then
Exit Function
End If
If Not GetRegistryEntry(HKEY_LOCAL_MACHINE, _ get printer driver file name from registry
"System\CurrentControlSet\Control\Print\Environments\Windows _
4.0\Drivers\" & DriverName, "Driver", DriverFile) Then
Exit Function
End If
If InStr(DriverFile, ".") Then remove .xxx extension
DriverFile = Left(DriverFile, InStr(DriverFile, ".") - 1)
End If
hdc = CreateICA(DriverFile, PrinterName, Port, 0&) get device context for printer
If hdc = 0 Then
Exit Function
End If
GetPrinterColours = GetDeviceCaps(hdc, NUMCOLORS) get number of colours printer can use
errortrap: handle errors
If hdc <> 0 Then dispose of device context
DeleteDC (hdc)
End If
Exit Function
End Function
Function GetRegistryEntry(ByVal hkey As Long, ByRef entry As String, _
ByRef value As String, ByRef returnstring As String) As Boolean
Const ERROR_NONE = 0
Const REG_SZ As Long = 1
Dim newkey, datalen As Long
GetRegistryEntry = False error return value
On Error GoTo errortrap try to open registry entry
If RegOpenKeyExA(hkey, entry, 0&, &H3F, newkey) <> ERROR_NONE
Then
Exit Function
End If
RegQueryValueExA newkey, value, 0&, REG_SZ, 0&, datalen get length of registry entry & set passed string length to suit
returnstring = String(datalen, 0)
If RegQueryValueExA(newkey, value, 0&, REG_SZ, returnstring, datalen) <> ERROR_NONE Then
RegCloseKey newkey read string data into passed parameter
Exit Function
End If
RegCloseKey newkey close registry entry
GetRegistryEntry = True return success value
errortrap: handle errors
Exit Function
End Function
Sponsoren und Investoren

Sponsoren und Investoren sind jederzeit herzlich willkommen!
Wenn Sie die Information(en) auf dieser Seite interessant fanden, freuen wir uns über eine kleine Spende. Empfehlen Sie uns bitte auch in Ihren Netzwerken (z. B. Twitter, Facebook oder Google+). Herzlichen Dank!

Nach oben Sitemap
Impressum & Kontakt