VB6 API获取并口、串口端口名和友好名

Option Explicit


Private Type GUID   'GUID数据类型


    Data(0 To 3) As Long


End Type


Private Type SP_DEVINFO_DATA '设备信息类型


    cbSize As Long      '数据表长度


    ClassGuid As GUID   '设备GUID值


    DevInst As Long     '设备句柄


    Reserved As Long    '保留


End Type


Private Const SPDRP_FRIENDLYNAME = &HC


Private Const DIGCF_DEFAULT = &H1           '只返回与系统默认设备相关的设备


Private Const DIGCF_PRESENT = &H2           '只返回当前存在的设备?


Private Const DIGCF_ALLCLASSES = &H4        '返回所有已安装的设备。如果这个标志设置了，ClassGuid参数将被忽略。


Private Const DIGCF_PROFILE = &H8           '只返回当前硬件配置文件中的设备?


Private Const DIGCF_DEVICEINTERFACE = &H10  '返回所有支持的设备?


Private Declare Function SetupDiGetClassDevs Lib "setupapi.dll" Alias "SetupDiGetClassDevsA" (ByVal ClassGuid As Long, ByVal Enumerator As Long, ByVal HwndParent As Long, ByVal flags As Long) As Long


Private Declare Function SetupDiEnumDeviceInfo Lib "setupapi.dll" (ByVal DeviceInfoSet As Long, ByVal MemberIndex As Long, ByRef deviceInfoData As SP_DEVINFO_DATA) As Boolean


Private Declare Function SetupDiDestroyDeviceInfoList Lib "setupapi.dll" (ByVal DeviceInfoSet As Long) As Long


Private Declare Function SetupDiGetDeviceRegistryProperty Lib "setupapi" Alias "SetupDiGetDeviceRegistryPropertyA" (ByVal DeviceInfoSet As Long, deviceInfoData As SP_DEVINFO_DATA, ByVal Property As Long, ByRef PropertyRegDataType As Long, ByVal PropertyBuffer As Long, ByVal PropertyBufferSize As Long, RequiredSize As Long) As Long


Private Declare Function SetupDiClassGuidsFromName Lib "setupapi.dll" Alias "SetupDiClassGuidsFromNameA" (ByVal ClassName As String, ClassGuidList As Long, ByVal ClassGuidListSize As Long, RequiredSize As Long) As Boolean


Private Declare Function SetupDiOpenDevRegKey Lib "setupapi.dll" (ByVal hDeviceInfo As Long, ByRef deviceInfoData As SP_DEVINFO_DATA, ByVal Scope As Long, ByVal hwprofile As Integer, ByVal parameterRegistryValueKind As Long, ByVal samDesired As Long) As Long


Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, ByRef lpType As Long, ByVal lpData As String, ByRef lpcbData As Long) As Long


Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hHey As Long) As Long


'获取串口设备属性信息，函数返回字符串包含并口、串口端口名和友好名


Public Function GetSerialPort() As String


    Dim objGuid As GUID, hDevInfo As Long, dwIndex As Long, lngRes As Long, dwSize As Long


    Dim objSpdd As SP_DEVINFO_DATA


    Dim hDrive As Long, dwBytesReturned As Long


    Dim dwReturn As Long, hKey As Long


    Dim lngDeviceNumber As String, szPortName As String


    Dim buffer() As Byte


    lngRes = SetupDiClassGuidsFromName("Ports", objGuid.Data(0), 1, dwSize)                 '获取类名为"Ports"的GUID


    If lngRes = 0 Then: GoTo exitFunction                                                   '有错误则报错后退出函数


    hDevInfo = SetupDiGetClassDevs(VarPtr(objGuid), 0, 0, DIGCF_PRESENT Or DIGCF_PROFILE)   '根据串口GUID获取设备句柄


    If hDevInfo = -1 Then: GoTo exitFunction                                                '有错误则报错后退出函数


    objSpdd.cbSize = Len(objSpdd)


    Do While 1


        lngRes = SetupDiEnumDeviceInfo(hDevInfo, dwIndex, objSpdd)  '根据设备句柄检举包含的设备


        If lngRes = 0 Then Exit Do                                  '检举返回无效则退出检举


        lngRes = SetupDiGetDeviceRegistryProperty(hDevInfo, objSpdd, SPDRP_FRIENDLYNAME, 0, 0&, 0, dwSize)   '根据dwIndex设备句柄请求FRIENDLYNAME访问


        If dwSize <= 0 Then GoTo exitFunction                        '设备无FRIENDLYNAME属性则结束函数


        ReDim buffer(dwSize)


        lngRes = SetupDiGetDeviceRegistryProperty(hDevInfo, objSpdd, SPDRP_FRIENDLYNAME, 0, VarPtr(buffer(0)), dwSize, dwSize)    '根据返回的FRIENDLYNAME信息指针获取dwIndex设备的FRIENDLYNAME的内容


        lngDeviceNumber = StrConv(buffer, vbUnicode)                '整理得到的FRIENDLYNAME字符串


        lngDeviceNumber = Left(lngDeviceNumber, InStr(lngDeviceNumber, Chr(0)) - 1)


        hKey = SetupDiOpenDevRegKey(hDevInfo, objSpdd, &H1, 0&, &H1, &H1)               '打开设备指定的注册表


        If hKey Then


            szPortName = Space(255)


            lngRes = RegQueryValueEx(hKey, "PortName", 0, &H80000000, szPortName, 1024) '获取串口设备PortName的键值


            RegCloseKey (hKey)


            If lngRes = 0 Then szPortName = Left(szPortName, InStr(szPortName, Chr(0)) - 1) Else szPortName = "Err " '整理得到的PortName字符串


        End If


        dwIndex = dwIndex + 1


        GetSerialPort = GetSerialPort & "PortName: " & szPortName & vbTab & "-> FriendlyName: " & lngDeviceNumber & vbCrLf


    Loop


exitFunction:


    Call SetupDiDestroyDeviceInfoList(hDevInfo)


End Function


Private Sub Command1_Click()
Call GetSerialPort
End Sub

还有一个

串口所在注册表。

Name = String(256, Chr(0))
ret = RegOpenKey(HKEY_LOCAL_MACHINE, "HARDWARE\DEVICEMAP\SERIALCOMM", hKey) '电脑COM口所在的注册表地址
If ret = 0 Then
    ret = RegQueryValueEx(hKey, "\Device\USBSER000", 0, 1, ByVal Name, Len(Name))
    RegCloseKey hKey
   ' MsgBox Name
Else
    MsgBox "配置失败，请确认是否已连接主板。"
End If