[VB6] How to get friendly name, bus reported device description or "location information" for HID devices

Module1.bas

Attribute VB_Name = "Module1"
Option Explicit

'--- for GetRawInputDeviceInfo
Private Const RIDI_DEVICENAME                       As Long = &H20000007
Private Const RIM_TYPEKEYBOARD                      As Long = 1
'--- for setupapi
Private Const DIGCF_PRESENT                         As Long = &H2
Private Const DIGCF_ALLCLASSES                      As Long = &H4
Private Const DIGCF_PROFILE                         As Long = &H8
Private Const DEVPROP_TYPE_STRING                   As Long = &H12
Private Const INVALID_HANDLE_VALUE                  As Long = -1
Private Const STD_OUTPUT_HANDLE                     As Long = -11&

Private Declare Function GetRawInputDeviceList Lib "user32" (pRawInputDeviceList As Any, puiNumDevices As Long, ByVal cbSize As Long) As Long
Private Declare Function GetRawInputDeviceInfo Lib "user32" Alias "GetRawInputDeviceInfoW" (ByVal hDevice As Long, ByVal uiCommand As Long, ByVal pData As Long, pcbSize As Long) As Long
Private Declare Function SetupDiGetClassDevs Lib "setupapi.dll" Alias "SetupDiGetClassDevsA" (ByRef Class As Any, ByVal Enumerator As String, ByVal Parent As Long, ByVal Flag As Long) As Long
Private Declare Function SetupDiDestroyDeviceInfoList Lib "setupapi.dll" (ByVal List As Long) As Boolean
Private Declare Function SetupDiEnumDeviceInfo Lib "setupapi.dll" (ByVal List As Long, ByVal Index As Long, ByRef Device As SP_DEVINFO) As Boolean
Private Declare Function SetupDiGetDeviceProperty Lib "setupapi.dll" Alias "SetupDiGetDevicePropertyW" (ByVal DeviceInfoSet As Long, DeviceInfoData As SP_DEVINFO, PropertyKey As SP_DEVPROPKEY, PropertyType As Long, ByVal PropertyBuffer As Long, ByVal PropertyBufferSize As Long, RequiredSize As Long, ByVal Flags As Long) As Long
Private Declare Function SetupDiGetDeviceRegistryProperty Lib "setupapi.dll" Alias "SetupDiGetDeviceRegistryPropertyA" (ByVal DeviceInfoSet As Long, DeviceInfoData As SP_DEVINFO, ByVal Property As DEVICEPROPERTYINDEX, PropertyRegDataType As REGPROPERTYTYPES, PropertyBuffer As Any, ByVal PropertyBufferSize As Long, RequiredSize As Long) As Long
Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (lpVersionInformation As OSVERSIONINFO) As Long
Private Declare Function GetStdHandle Lib "kernel32" (ByVal nStdHandle As Long) 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 CharToOemBuff Lib "user32" Alias "CharToOemBuffA" (ByVal lpszSrc As String, lpszDst As Any, ByVal cchDstLength As Long) As Long

Private Type OSVERSIONINFO
    dwOSVersionInfoSize As Long
    dwMajorVersion      As Long
    dwMinorVersion      As Long
    dwBuildNumber       As Long
    dwPlatformID        As Long
    szCSDVersion        As String * 128
End Type

Private Type RAWINPUTDEVICELIST
    hDevice             As Long
    dwType              As Long
End Type

Private Type SP_DEVINFO
    cbSize              As Long
    ClassGuid(0 To 3)   As Long
    DevInstance         As Long
    Reserved            As Long
End Type

Private Type SP_DEVPROPKEY
    fmtid(0 To 3)       As Long
    pid                 As Long
End Type

Public Enum DEVICEPROPERTYINDEX
    SPDRP_DEVICEDESC = &H0                       ' DeviceDesc (R/W)
    SPDRP_HARDWAREID = &H1                       ' HardwareID (R/W)
    SPDRP_COMPATIBLEIDS = &H2                    ' CompatibleIDs (R/W)
    SPDRP_UNUSED0 = &H3                          ' unused
    SPDRP_SERVICE = &H4                          ' Service (R/W)
    SPDRP_UNUSED1 = &H5                          ' unused
    SPDRP_UNUSED2 = &H6                          ' unused
    SPDRP_CLASS = &H7                            ' Class (R--tied to ClassGUID)
    SPDRP_CLASSGUID = &H8                        ' ClassGUID (R/W)
    SPDRP_DRIVER = &H9                           ' Driver (R/W)
    SPDRP_CONFIGFLAGS = &HA                      ' ConfigFlags (R/W)
    SPDRP_MFG = &HB                              ' Mfg (R/W)
    SPDRP_FRIENDLYNAME = &HC                     ' FriendlyName (R/W)
    SPDRP_LOCATION_INFORMATION = &HD             ' LocationInformation (R/W)
    SPDRP_PHYSICAL_DEVICE_OBJECT_NAME = &HE      ' PhysicalDeviceObjectName (R)
    SPDRP_CAPABILITIES = &HF                     ' Capabilities (R)
    SPDRP_UI_NUMBER = &H10                       ' UiNumber (R)
    SPDRP_UPPERFILTERS = &H11                    ' UpperFilters (R/W)
    SPDRP_LOWERFILTERS = &H12                    ' LowerFilters (R/W)
    SPDRP_BUSTYPEGUID = &H13                     ' BusTypeGUID (R)
    SPDRP_LEGACYBUSTYPE = &H14                   ' LegacyBusType (R)
    SPDRP_BUSNUMBER = &H15                       ' BusNumber (R)
    SPDRP_ENUMERATOR_NAME = &H16                 ' Enumerator Name (R)
    SPDRP_SECURITY = &H17                        ' Security (R/W, binary form)
    SPDRP_SECURITY_SDS = &H18                    ' Security (W, SDS form)
    SPDRP_DEVTYPE = &H19                         ' Device Type (R/W)
    SPDRP_EXCLUSIVE = &H1A                       ' Device is exclusive-access (R/W)
    SPDRP_CHARACTERISTICS = &H1B                 ' Device Characteristics (R/W)
    SPDRP_ADDRESS = &H1C                         ' Device Address (R)
    SPDRP_UI_NUMBER_DESC_FORMAT = &H1E           ' UiNumberDescFormat (R/W)
    SPDRP_MAXIMUM_PROPERTY = &H1F                ' Upper bound on ordinals
End Enum

Private Enum REGPROPERTYTYPES
    REG_SZ = 1
    REG_EXPAND_SZ = 2
    REG_BINARY = 3
    REG_DWORD = 4
    REG_DWORD_LITTLE_ENDIAN = 4
    REG_DWORD_BIG_ENDIAN = 5
    REG_MULTI_SZ = 7
End Enum

Public Enum UcsOsVersionEnum
    ucsOsvNt4 = 400
    ucsOsvWin98 = 410
    ucsOsvWin2000 = 500
    ucsOsvXp = 501
    ucsOsvVista = 600
    ucsOsvWin7 = 601
    ucsOsvWin8 = 602
    [ucsOsvWin8.1] = 603
    ucsOsvWin10 = 1000
End Enum

Private Function PrintError(sFunction As String) As VbMsgBoxResult

End Function

Private Sub Main()
    Dim vHidDevices     As Variant
    Dim vElem           As Variant
    
    vHidDevices = EnumHidDevices
    If Not IsArray(vHidDevices) Then
        ConsolePrint "No HID devices found." & vbCrLf
        Exit Sub
    End If
    For Each vElem In vHidDevices
        ConsolePrint At(vElem, 1) & " -> " & At(vElem, 0) & vbCrLf
    Next
End Sub

Public Property Get OsVersion() As UcsOsVersionEnum
    Static lVersion     As Long
    Dim uVer            As OSVERSIONINFO
    
    If lVersion = 0 Then
        uVer.dwOSVersionInfoSize = Len(uVer)
        If GetVersionEx(uVer) Then
            lVersion = uVer.dwMajorVersion * 100 + uVer.dwMinorVersion
        End If
    End If
    OsVersion = lVersion
End Property

Public Function EnumHidDevices() As Variant
    Const FUNC_NAME     As String = "EnumHidDevices"
    Dim lNumDevices     As Long
    Dim uList()         As RAWINPUTDEVICELIST
    Dim lIdx            As Long
    Dim vRet            As Variant
    Dim lCount          As Long
    Dim oSetupDevs      As Collection
    Dim sID             As String
    Dim vItem           As Variant
    
    On Error GoTo EH
    If OsVersion < ucsOsvXp Then
        GoTo QH
    End If
    If GetRawInputDeviceList(ByVal 0&, lNumDevices, Len(uList(0))) = -1 Then
        GoTo QH
    End If
    ReDim uList(0 To lNumDevices) As RAWINPUTDEVICELIST
    If GetRawInputDeviceList(uList(0), lNumDevices, Len(uList(0))) = -1 Then
        GoTo QH
    End If
    ReDim vRet(0 To lNumDevices) As Variant
    pvEnumSetupDevices "USB", oSetupDevs
    pvEnumSetupDevices vbNullString, oSetupDevs
    For lIdx = 0 To lNumDevices - 1
        If uList(lIdx).dwType = RIM_TYPEKEYBOARD Then
            sID = pvGetHidDevice(uList(lIdx).hDevice)
            If LenB(sID) <> 0 Then
                If SearchCollection(oSetupDevs, pvGetKeyFromID(sID), vItem) Then
                    vRet(lCount) = Array(sID, At(vItem, 0) & IIf(Right$(At(vItem, 0), 1) <> ")", " (" & At(vItem, 1) & ")", vbNullString))  '--- name (class)
                Else
                    vRet(lCount) = Array(sID, sID)
                End If
                lCount = lCount + 1
            End If
        End If
    Next
    If lCount > 0 Then
        ReDim Preserve vRet(0 To lCount - 1) As Variant
        EnumHidDevices = vRet
    End If
QH:
    Exit Function
EH:
    If PrintError(FUNC_NAME) = vbRetry Then
        Resume
    End If
    Resume Next
End Function

Private Function pvGetHidDevice(ByVal hDevice As Long) As String
    Dim lNeeded         As Long
        
    If GetRawInputDeviceInfo(hDevice, RIDI_DEVICENAME, 0, lNeeded) <> -1 Then
        pvGetHidDevice = String$(lNeeded + 1, 0)
        Call GetRawInputDeviceInfo(hDevice, RIDI_DEVICENAME, StrPtr(pvGetHidDevice), lNeeded)
        pvGetHidDevice = Left$(pvGetHidDevice, InStr(pvGetHidDevice, Chr$(0)) - 1)
        If InStrRev(pvGetHidDevice, "#") > InStrRev(pvGetHidDevice, "&") Then
            pvGetHidDevice = Left$(pvGetHidDevice, InStrRev(pvGetHidDevice, "#") - 1)
        End If
        If Left$(pvGetHidDevice, 4) = "\\?\" Then
            pvGetHidDevice = Replace(Mid$(pvGetHidDevice, 5), "#", "\")
        End If
    End If
End Function

Private Function pvEnumSetupDevices(Optional sEnumerator As String, Optional oCol As Collection) As Collection
    Const FUNC_NAME     As String = "pvEnumSetupDevices"
    Dim hDevInfo        As Long
    Dim uInfo           As SP_DEVINFO
    Dim lIdx            As Long
    Dim sID             As String
    Dim sClass          As String
    Dim sDevice         As String
    Dim uBusRptDeviceDesc As SP_DEVPROPKEY
    Dim sKey            As String

    On Error GoTo EH
'    ConsolePrint "before SetupDiGetClassDevs(sEnumerator=" & sEnumerator & ")" & vbCrLf
    hDevInfo = SetupDiGetClassDevs(ByVal 0&, sEnumerator, 0, DIGCF_PRESENT Or DIGCF_PROFILE Or DIGCF_ALLCLASSES)
    If hDevInfo = INVALID_HANDLE_VALUE Then
        GoTo QH
    End If
'    ConsolePrint "hDevInfo=" & hDevInfo & vbCrLf
    uBusRptDeviceDesc.fmtid(0) = &H540B947E
    uBusRptDeviceDesc.fmtid(1) = &H45BC8B40
    uBusRptDeviceDesc.fmtid(2) = &HB6AA2A8
    uBusRptDeviceDesc.fmtid(3) = &HA2BD4C89
    uBusRptDeviceDesc.pid = 4
    If oCol Is Nothing Then
        Set oCol = New Collection
    End If
    uInfo.cbSize = Len(uInfo)
    Do
'        ConsolePrint "lIdx=" & lIdx & vbCrLf
        If SetupDiEnumDeviceInfo(hDevInfo, lIdx, uInfo) = 0 Then
            Exit Do
        End If
        sID = pvGetSetupRegSetting(hDevInfo, uInfo, SPDRP_HARDWAREID)
        If LenB(sID) <> 0 Then
            sClass = pvGetSetupRegSetting(hDevInfo, uInfo, SPDRP_CLASS)
            sDevice = pvGetSetupRegSetting(hDevInfo, uInfo, SPDRP_FRIENDLYNAME)
            If LenB(sDevice) = 0 Then
                sDevice = pvGetSetupSetting(hDevInfo, uInfo, uBusRptDeviceDesc)
            End If
            If LenB(sDevice) = 0 And OsVersion <= ucsOsvXp Then
                sDevice = pvGetSetupRegSetting(hDevInfo, uInfo, SPDRP_LOCATION_INFORMATION)
                If sDevice <> "" Then
                    sDevice = sDevice
                End If
            End If
            If LenB(sDevice) = 0 Then
                sDevice = pvGetSetupRegSetting(hDevInfo, uInfo, SPDRP_DEVICEDESC)
            End If
            sKey = pvGetKeyFromID(sID)
            If LenB(sKey) <> 0 And Not SearchCollection(oCol, sKey) Then
                oCol.Add Array(sDevice, sClass, sKey, UCase$(sID)), sKey
            Else
                oCol.Add Array(sDevice, sClass, sKey, UCase$(sID))
            End If
        End If
        lIdx = lIdx + 1
    Loop
    Call SetupDiDestroyDeviceInfoList(hDevInfo)
QH:
    Set pvEnumSetupDevices = oCol
    Exit Function
EH:
    If PrintError(FUNC_NAME) = vbRetry Then
        Resume
    End If
    Resume Next
End Function

Private Function pvGetKeyFromID(sID As String, Optional sKeys As String = "VID PID MI") As String
    Dim vSplit          As Variant
    Dim vKey            As Variant
    Dim vElem           As Variant
    
    vSplit = Split(Replace(Replace(Replace(UCase$(sID), "\", " "), "&", " "), "#", " "))
    For Each vKey In Split(sKeys)
        For Each vElem In vSplit
            If Left$(vElem, Len(vKey) + 1) = vKey & "_" Then
                If LenB(pvGetKeyFromID) <> 0 Then
                    pvGetKeyFromID = pvGetKeyFromID & "#"
                End If
                pvGetKeyFromID = pvGetKeyFromID & Mid$(vElem, Len(vKey) + 2)
                GoTo NextLoop
            End If
        Next
        If LenB(pvGetKeyFromID) = 0 Then
            For Each vElem In vSplit
                Select Case vElem
                Case "??", vbNullString
                Case Else
                    If LenB(pvGetKeyFromID) <> 0 Then
                        pvGetKeyFromID = pvGetKeyFromID & "\" & vElem
                        Exit For
                    Else
                        pvGetKeyFromID = vElem
                    End If
                End Select
            Next
        End If
        Exit For
NextLoop:
    Next
End Function

Private Function pvGetSetupRegSetting(ByVal hDevInfo As Long, uInfo As SP_DEVINFO, ByVal RegSetting As DEVICEPROPERTYINDEX) As String
    Dim lType           As Long
    Dim lSize           As Long
    Dim sBuffer         As String
    Dim lValue          As Long
    
    On Error GoTo QH
    Call SetupDiGetDeviceRegistryProperty(hDevInfo, uInfo, RegSetting, lType, ByVal sBuffer, Len(sBuffer), lSize)
    Select Case lType
    Case 0
        '--- do nothing
    Case REG_SZ, REG_MULTI_SZ, REG_EXPAND_SZ, REG_BINARY
        sBuffer = String(2 * (lSize + 1), 0)
        If SetupDiGetDeviceRegistryProperty(hDevInfo, uInfo, RegSetting, lType, ByVal sBuffer, Len(sBuffer), lSize) <> 0 Then
            pvGetSetupRegSetting = Left$(sBuffer, InStr(sBuffer, Chr$(0)) - 1)
        End If
    Case REG_DWORD, REG_DWORD_BIG_ENDIAN, REG_DWORD_LITTLE_ENDIAN
        If SetupDiGetDeviceRegistryProperty(hDevInfo, uInfo, RegSetting, lType, lValue, 4, lSize) <> 0 Then
            pvGetSetupRegSetting = lValue
        End If
    Case Else
        pvGetSetupRegSetting = "Unknown reg prop type (" & lType & ")"
    End Select
QH:
End Function

Private Function pvGetSetupSetting(ByVal hDevInfo As Long, uInfo As SP_DEVINFO, uPropKey As SP_DEVPROPKEY) As String
    Dim lType           As Long
    Dim lSize           As Long
    Dim sBuffer         As String
    
    On Error GoTo QH
    Call SetupDiGetDeviceProperty(hDevInfo, uInfo, uPropKey, lType, StrPtr(sBuffer), LenB(sBuffer), lSize, 0)
    Select Case lType
    Case 0
        '--- do nothing
    Case DEVPROP_TYPE_STRING
        sBuffer = String(lSize \ 2 + 1, 0)
        If SetupDiGetDeviceProperty(hDevInfo, uInfo, uPropKey, lType, StrPtr(sBuffer), LenB(sBuffer), lSize, 0) <> 0 Then
            pvGetSetupSetting = Left$(sBuffer, InStr(sBuffer, Chr$(0)) - 1)
        End If
    Case Else
        pvGetSetupSetting = "Unknown prop type (" & lType & ")"
    End Select
QH:
End Function

Public Function SearchCollection(Col As Object, Index As Variant, Optional vItem As Variant) As Boolean
    On Error Resume Next
    vItem = Col(Index)
    SearchCollection = (Err.Number = 0)
    On Error GoTo 0
End Function

Public Function At(Data As Variant, ByVal Index As Long, Optional Default As String) As String
    On Error GoTo QH
    At = Default
    At = C_Str(Data(Index))
QH:
End Function

Public Function C_Str(v As Variant) As String
    On Error GoTo QH
    C_Str = CStr(v)
QH:
End Function

Private Function ConsolePrint(ByVal sText As String, ParamArray A() As Variant) As String
    Dim lIdx            As Long
    Dim sArg            As String
    Dim baBuffer()      As Byte
    Dim dwDummy         As Long
    Dim hOut            As Long
    
    '--- format
    For lIdx = UBound(A) To LBound(A) Step -1
        sArg = Replace(A(lIdx), "%", ChrW$(&H101))
        sText = Replace(sText, "%" & (lIdx - LBound(A) + 1), sArg)
    Next
    ConsolePrint = Replace(sText, ChrW$(&H101), "%")
    '--- output
    hOut = GetStdHandle(STD_OUTPUT_HANDLE)
    Debug.Print ConsolePrint;
    If hOut <> 0 Then
        ReDim baBuffer(1 To Len(ConsolePrint)) As Byte
        If CharToOemBuff(ConsolePrint, baBuffer(1), UBound(baBuffer)) Then
            Call WriteFile(hOut, baBuffer(1), UBound(baBuffer), dwDummy, ByVal 0&)
        End If
    End If
End Function

Project1.vbp

Type=Exe
Reference=*\G{00020430-0000-0000-C000-000000000046}#2.0#0#..\..\..\..\Windows\SysWOW64\stdole2.tlb#OLE Automation
Module=Module1; Module1.bas
Startup="Sub Main"
ExeName32="Project1.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