都是四處收集來的結果。
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