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

Option ExplicitPrivate Type GUID   'GUID数据类型    Data(0 To 3) As LongEnd TypePrivate Type SP_DEVINFO_DATA '设备信息类型    cbSize As Long      '数据表长度    ClassGuid As GUID   '设备GUID值    DevInst As Long     '设备句柄    Reserved As Long    '保留End TypePrivate Const SPDRP_FRIENDLYNAME = &HCPrivate 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 LongPrivate Declare Function SetupDiEnumDeviceInfo Lib "setupapi.dll" (ByVal DeviceInfoSet As Long, ByVal MemberIndex As Long, ByRef deviceInfoData As SP_DEVINFO_DATA) As BooleanPrivate Declare Function SetupDiDestroyDeviceInfoList Lib "setupapi.dll" (ByVal DeviceInfoSet As Long) As LongPrivate 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 LongPrivate Declare Function SetupDiClassGuidsFromName Lib "setupapi.dll" Alias "SetupDiClassGuidsFromNameA" (ByVal ClassName As String, ClassGuidList As Long, ByVal ClassGuidListSize As Long, RequiredSize As Long) As BooleanPrivate 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 LongPrivate 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 LongPrivate 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    LoopexitFunction:    Call SetupDiDestroyDeviceInfoList(hDevInfo)End FunctionPrivate Sub Command1_Click()Call GetSerialPortEnd 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