Get USB Printers Win32 Device Paths

mdStartup.bas

'--- mdStartup.bas
Option Explicit
DefObj A-Z

'=========================================================================
' API
'=========================================================================

Private Const STD_OUTPUT_HANDLE             As Long = -11&
'--- for CreateFile
Private Const GENERIC_READ                  As Long = &H80000000
Private Const GENERIC_WRITE                 As Long = &H40000000
Private Const OPEN_EXISTING                 As Long = 3
Private Const INVALID_HANDLE_VALUE          As Long = -1

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, ByVal lpSecurityAttributes As Long, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function ReadFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long, lpOverlapped As Any) As Long
Private Declare Function WriteFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Long, lpOverlapped As Any) As Long
Private Declare Function GetStdHandle Lib "kernel32" (ByVal nStdHandle As Long) As Long
Private Declare Function CharToOemBuffA Lib "user32" (ByVal lpszSrc As String, lpszDst As Any, ByVal cchDstLength As Long) As Long
Private Declare Function CommandLineToArgvW Lib "shell32" (ByVal lpCmdLine As Long, pNumArgs As Long) As Long
Private Declare Function LocalFree Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function SysReAllocString Lib "oleaut32" (ByVal pBSTR As Long, Optional ByVal pszStrPtr As Long) As Long
Private Declare Function OpenPrinter Lib "winspool.drv" Alias "OpenPrinterW" (ByVal pPrinterName As Long, phPrinter As Long, ByVal pDefault As Long) As Long
Private Declare Function ClosePrinter Lib "winspool.drv" (ByVal hPrinter As Long) As Long
Private Declare Function GetPrinter Lib "winspool.drv" Alias "GetPrinterW" (ByVal hPrinter As Long, ByVal Level As Long, pPrinter As Any, ByVal cbBuf As Long, pcbNeeded As Long) As Long
Private Declare Function IsBadReadPtr Lib "kernel32" (ByVal lp As Long, ByVal ucb As Long) As Long

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
    pSepFile            As Long
    pPrintProcessor     As Long
    pDatatype           As Long
    pParameters         As Long
    pSecurityDescriptor As Long
    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
Private Const sizeof_PRINTER_INFO_2 As Long = 84

Private m_baInfoData() As Byte

'=========================================================================
' Functions
'=========================================================================

Private Sub Main()
    Dim vArgs           As Variant
    Dim oPrinter        As VB.Printer
    Dim sDevicePath     As String
    Dim sPortName       As String
    Dim sPortPath       As String
    Dim vElem           As Variant
    
    vArgs = SplitArgs(Command$)
    If UBound(vArgs) < 0 Then
        ConsolePrint "Dumping All USB Printers" & vbCrLf
        ConsolePrint "=================================================================" & vbCrLf
        For Each oPrinter In Printers
            ConsolePrint "DeviceName : " & oPrinter.DeviceName & vbCrLf
            sDevicePath = GetUsbDevicePath(oPrinter.DeviceName)
            ConsolePrint "DevicePath : " & sDevicePath & vbCrLf
            sPortName = pvToString(pvGetPrinterInfo(oPrinter.DeviceName).pPortName)
            ConsolePrint "PortName   : " & sPortName & vbCrLf
            sPortPath = GetUsbDevicePath(sPortName)
            ConsolePrint "PortPath   : " & sPortPath & vbCrLf
            ConsolePrint "Status     : " & Replace(pvGetZebraStatus(IIf(LenB(sDevicePath) <> 0, sDevicePath, sPortPath)), vbCrLf, vbCrLf & "             ") & vbCrLf
            ConsolePrint "-----------------------------------------------------------------------------------------" & vbCrLf
        Next
    Else
        ConsolePrint "Dumping USB Devices" & vbCrLf
        ConsolePrint "=================================================================" & vbCrLf
        For Each vElem In vArgs
            ConsolePrint "UsbDevice  : " & vElem & vbCrLf
            sDevicePath = GetUsbDevicePath(vElem)
            ConsolePrint "DevicePath : " & sDevicePath & vbCrLf
            ConsolePrint "Status     : " & Replace(pvGetZebraStatus(sDevicePath), vbCrLf, vbCrLf & "             ") & vbCrLf
            ConsolePrint "-----------------------------------------------------------------------------------------" & vbCrLf
        Next
    End If
End Sub

Private Function pvGetZebraStatus(sDevice As String) As String
    Const STR_STATUS    As String = "~HS"
    Dim hFile           As Long
    Dim lBytes          As Long
    Dim baBuffer()      As Byte
    
    If LenB(sDevice) = 0 Then
        GoTo QH
    End If
    hFile = CreateFile(sDevice, GENERIC_READ Or GENERIC_WRITE, 0, 0, OPEN_EXISTING, 0, 0)
    If hFile = INVALID_HANDLE_VALUE Then
        ConsolePrint "ERROR: Cannot open file (%1)" & vbCrLf, Err.LastDllError
        GoTo QH
    End If
    If WriteFile(hFile, ByVal STR_STATUS, Len(STR_STATUS), lBytes, ByVal 0) = 0 Then
        ConsolePrint "ERROR: Cannot write to file (%1)" & vbCrLf, Err.LastDllError
        GoTo QH
    End If
    ReDim baBuffer(0 To 1024) As Byte
    If ReadFile(hFile, baBuffer(0), 1024, lBytes, ByVal 0) = 0 Then
        ConsolePrint "ERROR: Cannot read from file (%1)" & vbCrLf, Err.LastDllError
        GoTo QH
    End If
    If lBytes > 0 Then
        ReDim Preserve baBuffer(0 To lBytes - 1) As Byte
        pvGetZebraStatus = preg_replace("[\x00-\x09\x0B\x0C\x0E-\x1F]", StrConv(baBuffer, vbUnicode), ".") & DesignDumpMemory(VarPtr(baBuffer(0)), lBytes)
    End If
QH:
    If hFile <> 0 And hFile <> INVALID_HANDLE_VALUE Then
        Call CloseHandle(hFile)
    End If
End Function

Private Function ConsolePrint(ByVal sText As String, ParamArray A() As Variant) As String
    ConsolePrint = pvConsoleOutput(GetStdHandle(STD_OUTPUT_HANDLE), sText, CVar(A))
End Function

Private Function pvConsoleOutput(ByVal hOut As Long, ByVal sText As String, A As Variant) As String
    Const LNG_PRIVATE   As Long = &HE1B6& '-- U+E000 to U+F8FF - Private Use Area (PUA)
    Dim lIdx            As Long
    Dim sArg            As String
    Dim baBuffer()      As Byte
    Dim dwDummy         As Long

    If LenB(sText) = 0 Then
        Exit Function
    End If
    '--- format
    For lIdx = UBound(A) To LBound(A) Step -1
        sArg = Replace(A(lIdx), "%", ChrW$(LNG_PRIVATE))
        sText = Replace(sText, "%" & (lIdx - LBound(A) + 1), sArg)
    Next
    pvConsoleOutput = Replace(sText, ChrW$(LNG_PRIVATE), "%")
    '--- output
    If hOut = 0 Then
        Debug.Print pvConsoleOutput;
    Else
        ReDim baBuffer(0 To Len(pvConsoleOutput) - 1) As Byte
        If CharToOemBuffA(pvConsoleOutput, baBuffer(0), UBound(baBuffer) + 1) <> 0 Then
            Call WriteFile(hOut, baBuffer(0), UBound(baBuffer) + 1, dwDummy, ByVal 0&)
        End If
    End If
End Function

Private Function SplitArgs(sText As String) As Variant
    Dim vRetVal         As Variant
    Dim lPtr            As Long
    Dim lArgc           As Long
    Dim lIdx            As Long
    Dim lArgPtr         As Long

    If LenB(sText) <> 0 Then
        lPtr = CommandLineToArgvW(StrPtr(sText), lArgc)
    End If
    If lArgc > 0 Then
        ReDim vRetVal(0 To lArgc - 1) As String
        For lIdx = 0 To UBound(vRetVal)
            Call CopyMemory(lArgPtr, ByVal lPtr + 4 * lIdx, 4)
            vRetVal(lIdx) = pvToString(lArgPtr)
        Next
    Else
        vRetVal = Split(vbNullString)
    End If
    Call LocalFree(lPtr)
    SplitArgs = vRetVal
End Function

Private Function pvToString(ByVal lPtr As Long) As String
    Call SysReAllocString(VarPtr(pvToString), lPtr)
End Function

Private Function pvGetPrinterInfo(sPrinterName As String) As PRINTER_INFO_2
    Dim hPrinter        As Long
    Dim lNeeded         As Long
    
    If OpenPrinter(StrPtr(sPrinterName), hPrinter, 0) <> 0 Then
        Call GetPrinter(hPrinter, 2, ByVal 0, 0, lNeeded)
        ReDim m_baInfoData(0 To lNeeded) As Byte
        Call GetPrinter(hPrinter, 2, m_baInfoData(0), lNeeded, lNeeded)
        Call ClosePrinter(hPrinter)
    End If
    If UBound(m_baInfoData) >= sizeof_PRINTER_INFO_2 Then
        Call CopyMemory(pvGetPrinterInfo, m_baInfoData(0), sizeof_PRINTER_INFO_2)
    End If
End Function

Private Function preg_replace(find_re As String, sText As String, Optional Replace As String) As String
    With CreateObject("VBScript.RegExp")
        .Global = True
        .Pattern = find_re
        preg_replace = .Replace(sText, Replace)
    End With
End Function

Private Function DesignDumpMemory(ByVal lPtr As Long, ByVal lSize As Long) As String
    Dim lIdx            As Long
    Dim sHex            As String
    Dim sChar           As String
    Dim lValue          As Long
    Dim aResult()       As String
    
    ReDim aResult(0 To (lSize + 15) \ 16) As String
    For lIdx = 0 To ((lSize + 15) \ 16) * 16
        If lIdx < lSize Then
            If IsBadReadPtr(lPtr, 1) = 0 Then
                Call CopyMemory(lValue, ByVal lPtr, 1)
                sHex = sHex & Right$("0" & Hex$(lValue), 2) & " "
                If lValue >= 32 Then
                    sChar = sChar & Chr$(lValue)
                Else
                    sChar = sChar & "."
                End If
            Else
                sHex = sHex & "?? "
                sChar = sChar & "."
            End If
        Else
            sHex = sHex & "   "
        End If
        If ((lIdx + 1) Mod 4) = 0 Then
            sHex = sHex & " "
        End If
        If ((lIdx + 1) Mod 16) = 0 Then
            aResult(lIdx \ 16) = Right$("000" & Hex$(lIdx - 15), 4) & " - " & sHex & sChar
            sHex = vbNullString
            sChar = vbNullString
        End If
        lPtr = (lPtr Xor &H80000000) + 1 Xor &H80000000
    Next
    DesignDumpMemory = Join(aResult, vbCrLf)
End Function

mdUsbPrinters.bas

'--- mdUsbPrinters.bas
Option Explicit
DefObj A-Z

'=========================================================================
' API
'=========================================================================

Private Declare Function CM_Locate_DevNode Lib "cfgmgr32" Alias "CM_Locate_DevNodeW" (pdnDevInst As Long, ByVal pDeviceID As Long, ByVal ulFlags As Long) As Long
Private Declare Function CM_Get_Parent Lib "cfgmgr32" (pdnDevInst As Long, ByVal dnDevInst As Long, ByVal ulFlags As Long) As Long
Private Declare Function CM_Get_Device_ID Lib "cfgmgr32" Alias "CM_Get_Device_IDW" (ByVal dnDevInst As Long, ByVal Buffer As Long, ByVal BufferLen As Long, ByVal ulFlags As Long) As Long
Private Declare Function SetupDiGetClassDevs Lib "setupapi" Alias "SetupDiGetClassDevsW" (ByVal ClassGuid As Long, ByVal Enumerator As Long, ByVal hwndParent As Long, ByVal Flags As Long) As Long
Private Declare Function SetupDiEnumDeviceInfo Lib "setupapi" (ByVal DeviceInfoSet As Long, ByVal MemberIndex As Long, ByRef DeviceInfoData As SP_DEVINFO_DATA) As Long
Private Declare Function SetupDiGetDeviceRegistryProperty Lib "setupapi" Alias "SetupDiGetDeviceRegistryPropertyW" (ByVal DeviceInfoSet As Long, ByRef DeviceInfoData As SP_DEVINFO_DATA, ByVal Proprty As Long, ByRef PropertyRegDataType As Long, ByVal PropertyBuffer As Long, ByVal PropertyBufferSize As Long, ByRef RequiredSize As Long) As Long
Private Declare Function SetupDiDestroyDeviceInfoList Lib "setupapi" (ByVal DeviceInfoSet As Long) As Long
Private Declare Function SetupDiEnumDeviceInterfaces Lib "setupapi" (ByVal DeviceInfoSet As Long, ByVal DeviceInfoData As Long, ByVal InterfaceClassGuid As Long, ByVal MemberIndex As Long, ByRef DeviceInterfaceData As SP_DEVICE_INTERFACE_DATA) As Long
Private Declare Function SetupDiGetDeviceInterfaceDetail Lib "setupapi" Alias "SetupDiGetDeviceInterfaceDetailW" (ByVal DeviceInfoSet As Long, ByRef DeviceInterfaceData As SP_DEVICE_INTERFACE_DATA, ByVal pDetailData As Long, ByVal DetailDataSize As Long, ByRef RequiredSize As Long, ByVal DeviceInfoData As Long) As Long
Private Declare Function SysReAllocString Lib "oleaut32" (ByVal pBSTR As Long, Optional ByVal pszStrPtr As Long) As Long

Private Const DIGCF_PRESENT                 As Long = &H2
Private Const DIGCF_ALLCLASSES              As Long = &H4
Private Const DIGCF_DEVICEINTERFACE         As Long = &H10
Private Const SPDRP_FRIENDLYNAME            As Long = &HC

Private Type SP_DEVINFO_DATA
    cbSize                      As Long
    ClassGuid(0 To 3)           As Long
    DevInst                     As Long
    Reserved                    As Long
End Type

Private Type SP_DEVICE_INTERFACE_DATA
    cbSize                      As Long
    InterfaceClassGuid(0 To 3)  As Long
    Flags                       As Long
    Reserved                    As Long
End Type

'=========================================================================
' Functions
'=========================================================================

Public Function GetUsbDevicePath(ByVal sDevice As String) As String
    Dim vElem           As Variant

    If Left$(sDevice, 2) = "\\" Then
        GetUsbDevicePath = sDevice
    End If
    If LenB(GetUsbDevicePath) = 0 Then
        '--- try mapping "USB001" port name
        GetUsbDevicePath = pvGetPortDevicePath(sDevice)
    End If
    If LenB(GetUsbDevicePath) = 0 Then
        '--- try mapping "HPRT Alpha (203 dpi)" printer name
        For Each vElem In pvGetPrinterDeviceIDs(sDevice)
            Do While LenB(vElem) <> 0
                GetUsbDevicePath = pvGetInterfaceDevicePath(vElem)
                If LenB(GetUsbDevicePath) <> 0 Then
                    Exit For
                End If
                vElem = pvGetParentDeviceID(vElem)
            Loop
        Next
    End If
End Function

'= private ===============================================================

'Private Function pvGetDeviceIDs(ByVal sDeviceName As String) As Collection
'    Dim oItem As Object
'
'    Set pvGetDeviceIDs = New Collection
'    With GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2")
'        For Each oItem In .ExecQuery("SELECT PNPDeviceID FROM Win32_PnPEntity WHERE Name='" & Replace(sDeviceName, "'", "''") & "'")
'            pvGetDeviceIDs.Add oItem.PNPDeviceID
'        Next
'    End With
'End Function

Private Function pvGetPrinterDeviceIDs(ByVal sPrinterName As String) As Collection
    Dim hDev            As Long
    Dim uDevData        As SP_DEVINFO_DATA
    Dim sBuffer         As String
    Dim lIdx            As Long
    
    Set pvGetPrinterDeviceIDs = New Collection
    hDev = SetupDiGetClassDevs(0, 0, 0, DIGCF_ALLCLASSES)
    If hDev = -1 Then
        GoTo QH
    End If
    For lIdx = 0 To 9999
        uDevData.cbSize = LenB(uDevData)
        If SetupDiEnumDeviceInfo(hDev, lIdx, uDevData) = 0 Then
            Exit For
        End If
        sBuffer = String$(1024, 0)
        If SetupDiGetDeviceRegistryProperty(hDev, uDevData, SPDRP_FRIENDLYNAME, 0, StrPtr(sBuffer), LenB(sBuffer) - 2, 0) <> 0 Then
            sBuffer = Left$(sBuffer, InStr(sBuffer, vbNullChar) - 1)
            If StrComp(sBuffer, sPrinterName, vbTextCompare) = 0 Then
                sBuffer = String$(1024, 0)
                If CM_Get_Device_ID(uDevData.DevInst, StrPtr(sBuffer), Len(sBuffer) - 1, 0) = 0 Then
                    pvGetPrinterDeviceIDs.Add Left$(sBuffer, InStr(sBuffer, vbNullChar) - 1)
                End If
            End If
        End If
    Next
QH:
    If hDev <> 0 Then
        Call SetupDiDestroyDeviceInfoList(hDev)
    End If
End Function

Private Function pvGetParentDeviceID(ByVal sDeviceID As String) As String
    Dim hDevInst        As Long
    Dim hParentInst     As Long
    Dim sBuffer         As String
    
    If LenB(sDeviceID) = 0 Then
        GoTo QH
    End If
    If CM_Locate_DevNode(hDevInst, StrPtr(sDeviceID), 0) <> 0 Then
        GoTo QH
    End If
    If CM_Get_Parent(hParentInst, hDevInst, 0) <> 0 Then
        GoTo QH
    End If
    sBuffer = String$(1024, 0)
    If CM_Get_Device_ID(hParentInst, StrPtr(sBuffer), Len(sBuffer) - 1, 0) <> 0 Then
        GoTo QH
    End If
    pvGetParentDeviceID = Left$(sBuffer, InStr(sBuffer, vbNullChar) - 1)
QH:
End Function

Private Function pvGetInterfaceDevicePath(ByVal sDeviceID As String) As String
    Dim uGuid(0 To 3)   As Long
    Dim hDev            As Long
    Dim uDevData        As SP_DEVINFO_DATA
    Dim uIfData         As SP_DEVICE_INTERFACE_DATA
    Dim lSize           As Long
    Dim baBuffer()      As Byte
    
    If LenB(sDeviceID) = 0 Then
        GoTo QH
    End If
    '--- GUID_DEVINTERFACE_USBPRINT = {28D78FAD-5A12-11D1-AE5B-0000F803A8C2}
    uGuid(0) = &H28D78FAD: uGuid(1) = &H11D15A12: uGuid(2) = &H5BAE&: uGuid(3) = &HC2A803F8
    hDev = SetupDiGetClassDevs(VarPtr(uGuid(0)), StrPtr(sDeviceID), 0, DIGCF_PRESENT Or DIGCF_DEVICEINTERFACE)
    If hDev = -1 Then
        GoTo QH
    End If
    uDevData.cbSize = LenB(uDevData)
    If SetupDiEnumDeviceInfo(hDev, 0, uDevData) = 0 Then
        GoTo QH
    End If
    uIfData.cbSize = LenB(uIfData)
    If SetupDiEnumDeviceInterfaces(hDev, VarPtr(uDevData), VarPtr(uGuid(0)), 0, uIfData) = 0 Then
        GoTo QH
    End If
    Call SetupDiGetDeviceInterfaceDetail(hDev, uIfData, 0, 0, lSize, 0)
    If lSize = 0 Then
        GoTo QH
    End If
    ReDim baBuffer(0 To lSize - 1) As Byte
    baBuffer(0) = 6
    If SetupDiGetDeviceInterfaceDetail(hDev, uIfData, VarPtr(baBuffer(0)), UBound(baBuffer) + 1, 0, 0) = 0 Then
        GoTo QH
    End If
    '--- success
    pvGetInterfaceDevicePath = pvToString(VarPtr(baBuffer(4)))
QH:
    If hDev <> 0 Then
        Call SetupDiDestroyDeviceInfoList(hDev)
    End If
End Function

Private Function pvGetPortDevicePath(ByVal sPortName As String) As String
    Const HKLM          As Long = &H80000002
    Dim sKey            As String
    
    sKey = "SYSTEM\CurrentControlSet\Control\Print\Monitors\USB Monitor\Ports\" & sPortName
    With GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\default:StdRegProv")
        .GetStringValue HKLM, sKey, "Device Path", pvGetPortDevicePath
    End With
End Function

Private Function pvToString(ByVal lPtr As Long) As String
    Call SysReAllocString(VarPtr(pvToString), lPtr)
End Function

Project1.vbp

Type=Exe
Reference=*\G{00020430-0000-0000-C000-000000000046}#2.0#0#..\..\..\Windows\SysWOW64\stdole2.tlb#OLE Automation
Module=mdUsbPrinters; mdUsbPrinters.bas
Module=mdStartup; mdStartup.bas
Startup="Sub Main"
ExeName32="UsbPrinters.exe"
Command32=""
Name="Project1"
HelpContextID="0"
CompatibleMode="0"
MajorVer=1
MinorVer=0
RevisionVer=0
AutoIncrementVer=0
ServerSupportFiles=0
VersionCompanyName="Unicontsoft"
CompilationType=0
OptimizationType=0
FavorPentiumPro(tm)=0
CodeViewDebugInfo=0
NoAliasing=0
BoundsCheck=0
OverflowCheck=0
FlPointCheck=0
FDIVCheck=0
UnroundedFP=0
StartMode=0
Unattended=0
Retained=0
ThreadPerObject=0
MaxNumberOfThreads=1

[VBCompiler]
LinkSwitches=/SUBSYSTEM:CONSOLE