Option Explicit
' Win32 API declares
Private Declare Function OpenPrinter Lib "winspool.drv" _
Alias "OpenPrinterA" (ByVal pPrinterName As String, _
phPrn As Long, pDefault As Any) As Long
Private Declare Function ClosePrinter Lib "winspool.drv" _
(ByVal hPrn As Long) As Long
Private Declare Function GetPrinter Lib "winspool.drv" _
Alias "GetPrinterA" (ByVal hPrinter As Long, _
ByVal Level As Long, pPrinter As Any, _
ByVal cbBuf As Long, pcbNeeded As Long) As Long
Private Declare Function SetPrinter Lib "winspool.drv" _
Alias "SetPrinterA" (ByVal hPrinter As Long, _
ByVal Level As Long, pPrinter As Any, _
ByVal Command As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" _
Alias "RtlMoveMemory" (Destination As Any, _
Source As Any, ByVal Length As Long)
Private Declare Function lstrlenA Lib "kernel32" _
(ByVal lpString As Long) As Long
Private Declare Function FormatMessage Lib "kernel32" _
Alias "FormatMessageA" (ByVal dwFlags As Long, _
lpSource As Any, ByVal dwMessageId As Long, _
ByVal dwLanguageId As Long, ByVal lpBuffer As String, _
ByVal nSize As Long, Arguments As Long) As Long
' The data area passed to a system call is too small.
Private Const ERROR_INSUFFICIENT_BUFFER As Long = 122
' Printer status flags used with PRINTER_INFORMATION_2
Private Const PRINTER_STATUS_READY As Long = &H0
Private Const PRINTER_STATUS_PAUSED As Long = &H1
Private Const PRINTER_STATUS_ERROR As Long = &H2
Private Const PRINTER_STATUS_PENDING_DELETION As Long = &H4
Private Const PRINTER_STATUS_PAPER_JAM As Long = &H8
Private Const PRINTER_STATUS_PAPER_OUT As Long = &H10
Private Const PRINTER_STATUS_MANUAL_FEED As Long = &H20
Private Const PRINTER_STATUS_PAPER_PROBLEM As Long = &H40
Private Const PRINTER_STATUS_OFFLINE As Long = &H80
Private Const PRINTER_STATUS_IO_ACTIVE As Long = &H100
Private Const PRINTER_STATUS_BUSY As Long = &H200
Private Const PRINTER_STATUS_PRINTING As Long = &H400
Private Const PRINTER_STATUS_OUTPUT_BIN_FULL As Long = &H800
Private Const PRINTER_STATUS_NOT_AVAILABLE As Long = &H1000
Private Const PRINTER_STATUS_WAITING As Long = &H2000
Private Const PRINTER_STATUS_PROCESSING As Long = &H4000
Private Const PRINTER_STATUS_INITIALIZING As Long = &H8000
Private Const PRINTER_STATUS_WARMING_UP As Long = &H10000
Private Const PRINTER_STATUS_TONER_LOW As Long = &H20000
Private Const PRINTER_STATUS_NO_TONER As Long = &H40000
Private Const PRINTER_STATUS_PAGE_PUNT As Long = &H80000
Private Const PRINTER_STATUS_USER_INTERVENTION As Long = &H100000
Private Const PRINTER_STATUS_OUT_OF_MEMORY As Long = &H200000
Private Const PRINTER_STATUS_DOOR_OPEN As Long = &H400000
Private Const PRINTER_STATUS_SERVER_UNKNOWN As Long = &H800000
Private Const PRINTER_STATUS_POWER_SAVE As Long = &H1000000
' Used to retrieve last API error text.
Private Const FORMAT_MESSAGE_FROM_SYSTEM As Long = &H1000
' VBA-friendly structure used to return the printer info.
Public Type PrinterInfo
ServerName As String
ShareName As String
PortName As String
DriverName As String
Comment As String
Location As String
SepFile As String
PrintProcessor As String
Datatype As String
Parameters As String
Status As String
Jobs As Long
End Type
' Structure used to obtain the data from Windows.
Private Type PRINTER_INFO_2
pServerName As Long
pPrinterName As Long
pShareName As Long
pPortName As Long
pDriverName As Long
pComment As Long
pLocation As Long
pDevMode As Long 'DEVMODE
pSepFile As Long
pPrintProcessor As Long
pDatatype As Long
pParameters As Long
pSecurityDescriptor As Long 'SECURITY_DESCRIPTOR
Attributes As Long
Priority As Long
DefaultPriority As Long
StartTime As Long
UntilTime As Long
Status As Long
cJobs As Long
AveragePPM As Long
End Type
Public Function GetPrinterDetails(Optional ByVal PrinterName As Variant) As PrinterInfo
Dim pi2 As PRINTER_INFO_2
Dim pi2_output As PrinterInfo
Dim hPrn As Long
Dim Buffer() As Byte
Dim BytesNeeded As Long
Dim BytesUsed As Long
Dim slash As Long
Dim DispName As String
Dim PrinterErrorCode As Long
Dim StatusCode As Long
'Use default printer if none specified
If IsMissing(PrinterName) Then
PrinterName = ActivePrinter
PrinterName = Left$(PrinterName, InStr(PrinterName, " on ") - 1)
End If
' Get handle to printer.
Call OpenPrinter(PrinterName, hPrn, ByVal 0&)
If hPrn Then
' Call once to get proper buffer size.
Call GetPrinter(hPrn, 2, ByVal 0&, 0, BytesNeeded)
If Err.LastDllError = ERROR_INSUFFICIENT_BUFFER Then
' Size buffer and get printer data.
ReDim Buffer(0 To BytesNeeded - 1) As Byte
If GetPrinter(hPrn, 2, Buffer(0), BytesNeeded, BytesUsed) Then
' Fill local structure with data/pointers.
Call CopyMemory(pi2, Buffer(0), Len(pi2))
' Transfer string data to output structure.
pi2_output.ServerName = PointerToStringA(pi2.pServerName)
pi2_output.ShareName = PointerToStringA(pi2.pShareName)
pi2_output.PortName = PointerToStringA(pi2.pPortName)
pi2_output.DriverName = PointerToStringA(pi2.pDriverName)
pi2_output.Comment = PointerToStringA(pi2.pComment)
pi2_output.Location = PointerToStringA(pi2.pLocation)
pi2_output.SepFile = PointerToStringA(pi2.pSepFile)
pi2_output.PrintProcessor = PointerToStringA(pi2.pPrintProcessor)
pi2_output.Datatype = PointerToStringA(pi2.pDatatype)
pi2_output.Parameters = PointerToStringA(pi2.pParameters)
Call CopyMemory(StatusCode, Buffer(72), 4)
Call CopyMemory(pi2_output.Jobs, Buffer(76), 4)
End If
PrinterErrorCode = 0 'clear error value
Else
PrinterErrorCode = Err.LastDllError
End If
pi2_output.Status = StatusText(StatusCode, PrinterErrorCode)
Call ClosePrinter(hPrn)
End If
GetPrinterDetails = pi2_output
End Function
Private Function PointerToStringA(ByVal lpStringA As Long) As String
Dim Buffer() As Byte
Dim nLen As Long
If lpStringA Then
nLen = lstrlenA(ByVal lpStringA)
If nLen Then
ReDim Buffer(0 To (nLen - 1)) As Byte
CopyMemory Buffer(0), ByVal lpStringA, nLen
PointerToStringA = StrConv(Buffer, vbUnicode)
End If
End If
End Function
Private Function StatusText(StatusCode As Long, ErrorCode As Long) As String
If ErrorCode Then
StatusText = ApiErrorText(ErrorCode)
Else
Select Case StatusCode
Case PRINTER_STATUS_READY
StatusText = "Ready"
Case PRINTER_STATUS_PAUSED
StatusText = "Paused"
Case PRINTER_STATUS_ERROR
StatusText = "Error"
Case PRINTER_STATUS_PENDING_DELETION
StatusText = "Deleting..."
Case PRINTER_STATUS_PAPER_JAM
StatusText = "Paper Jam"
Case PRINTER_STATUS_PAPER_OUT
StatusText = "Paper Out"
Case PRINTER_STATUS_MANUAL_FEED
StatusText = "Manual Feed Required"
Case PRINTER_STATUS_PAPER_PROBLEM
StatusText = "Paper Problem"
Case PRINTER_STATUS_OFFLINE
StatusText = "Offline"
Case PRINTER_STATUS_IO_ACTIVE
StatusText = "Downloading Job"
Case PRINTER_STATUS_BUSY
StatusText = "Busy"
Case PRINTER_STATUS_PRINTING
StatusText = "Printing"
Case PRINTER_STATUS_OUTPUT_BIN_FULL
StatusText = "Output Bill Full"
Case PRINTER_STATUS_NOT_AVAILABLE
StatusText = "Not Available"
Case PRINTER_STATUS_WAITING
StatusText = "Waiting"
Case PRINTER_STATUS_PROCESSING
StatusText = "Processing Job"
Case PRINTER_STATUS_INITIALIZING
StatusText = "Initializing"
Case PRINTER_STATUS_WARMING_UP
StatusText = "Warming Up"
Case PRINTER_STATUS_TONER_LOW
StatusText = "Toner Low"
Case PRINTER_STATUS_NO_TONER
StatusText = "Toner Out"
Case PRINTER_STATUS_PAGE_PUNT
StatusText = "Page too Complex"
Case PRINTER_STATUS_USER_INTERVENTION
StatusText = "User Intervention Required"
Case PRINTER_STATUS_OUT_OF_MEMORY
StatusText = "Out of Memory"
Case PRINTER_STATUS_DOOR_OPEN
StatusText = "Door Open"
Case PRINTER_STATUS_SERVER_UNKNOWN
StatusText = "Unable to connect"
Case PRINTER_STATUS_POWER_SAVE
StatusText = "Power Save Mode"
Case Else
StatusText = Hex$(StatusCode)
End Select
End If
End Function
Private Function ApiErrorText(ByVal ErrNum As Long) As String
Dim msg As String
Dim nRet As Long
msg = Space$(1024)
nRet = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, ByVal 0&, ErrNum, 0&, msg, Len(msg), ByVal 0&)
If nRet Then
ApiErrorText = Left$(msg, nRet - 2) ' account for Cr/Lf
Else
ApiErrorText = "Error (" & ErrNum & ") not defined."
End If
End Function
Sub test()
Dim pInfo As PrinterInfo
pInfo = GetPrinterDetails
MsgBox "Driver name is " & GetPrinterDetails.DriverName
MsgBox "Port name is " & pInfo.PortName
MsgBox "Printer status is " & pInfo.Status
End Sub