| 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 occurence 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 | |
| |
zurück