Option Explicit
Private Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Const HKEY_LOCAL_MACHINE = &H80000002
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegEnumValue Lib "advapi32.dll" Alias "RegEnumValueA" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpValueName As String, lpcbValueName As Long, ByVal lpReserved As Long, lpType As Long, lpData As String, lpcbData As Long) As Long
Private Sub Command3_Click()
Const ERROR_NO_MORE_ITEMS = 259&
Const BUFFER_SIZE As Long = 255
Dim hKey As Long, Cnt As Long, sName As String, sData As String, Ret As Long, RetData As Long
Ret = BUFFER_SIZE
Cnt = 0
If RegOpenKey(HKEY_LOCAL_MACHINE, "HardWare\DeviceMap\SerialComm", hKey) = 0 Then
sName = Space(BUFFER_SIZE)
sData = Space(BUFFER_SIZE)
Ret = BUFFER_SIZE
RetData = BUFFER_SIZE
While RegEnumValue(hKey, Cnt, sName, Ret, 0, ByVal 0&, ByVal sData, RetData) <> ERROR_NO_MORE_ITEMS
If RetData > 0 Then
List1.AddItem Left$(sData, RetData - 1)
End If
Cnt = Cnt + 1
sName = Space(BUFFER_SIZE)
sData = Space(BUFFER_SIZE)
Ret = BUFFER_SIZE
RetData = BUFFER_SIZE
Wend
RegCloseKey hKey
Else
MsgBox " 错误"
End If
End Sub
Const HKEY_CURRENT_CONFIG = &H80000005
Const HKEY_LOCAL_MACHINE = &H80000002
Const REG_SZ = 1
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Declare Function RegEnumKeyEx Lib "advapi32.dll" Alias "RegEnumKeyExA" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpName As String, lpcbName As Long, ByVal lpReserved As Long, ByVal lpClass As String, lpcbClass As Long, lpftLastWriteTime As Any) As Long
Private Declare Function RegEnumValue Lib "advapi32.dll" Alias "RegEnumValueA" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpValueName As String, lpcbValueName As Long, ByVal lpReserved As Long, lpType As Long, lpData As Byte, lpcbData 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, lpType As Long, lpData As Any, lpcbData As Long) As Long
Private Sub Form_Paint()
Dim hKey As Long, Cnt As Long, sSave As String
Dim strRet As String
Dim lRet As Long
Me.Cls
Me.Print "RegEnumValue:"
RegOpenKey HKEY_LOCAL_MACHINE, "HARDWARE\DEVICEMAP\SERIALCOMM", hKey
Cnt = 0
Do
sSave = String(255, 0)
If RegEnumValue(hKey, Cnt, sSave, 255, 0, ByVal 0&, ByVal 0&, ByVal 0&) <> 0 Then Exit Do
strRet = StripTerminator(sSave)
Me.Print strRet & vbTab;
sSave = String(255, 0)
If RegQueryValueEx(hKey, strRet, 0, REG_SZ, ByVal sSave, 255) = 0 Then
strRet = StripTerminator(sSave)
Me.Print strRet
End If
Cnt = Cnt + 1
Loop
RegCloseKey hKey
End Sub
Private Function StripTerminator(sInput As String) As String
Dim ZeroPos As Integer
ZeroPos = InStr(1, sInput, vbNullChar)
If ZeroPos > 0 Then
StripTerminator = Left$(sInput, ZeroPos - 1)
Else
StripTerminator = sInput
End If
End Function
枚举注册表下的值:
HKEY_LOCAL_MACHINE\HARDWARE\DEVICEMAP\SERIALCOMM
,用API也行,但他会列出所有的端口(包括并口)。
【VB声明】
Private Declare Function EnumPorts Lib "winspool.drv" Alias "EnumPortsA" (ByVal pName As String, ByVal Level As Long, ByVal lpbPorts As Long, ByVal cbBuf As Long, pcbNeeded As Long, pcReturned As Long) As Long
'==============================================
Private Type PORT_INFO_2
pPortName As String
pMonitorName As String
pDescription As String
fPortType As Long
Reserved As Long
End Type
Private Type API_PORT_INFO_2
pPortName As Long
pMonitorName As Long
pDescription As Long
fPortType As Long
Reserved As Long
End Type
Private Declare Function EnumPorts Lib "winspool.drv" Alias "EnumPortsA" (ByVal pName As String, ByVal Level As Long, ByVal lpbPorts As Long, ByVal cbBuf As Long, pcbNeeded As Long, pcReturned As Long) As Long
Private Declare Function lstrlenW Lib "kernel32" (ByVal lpString As Long) As Long
Private Declare Sub CopyMem Lib "kernel32" Alias "RtlMoveMemory" (pTo As Any, uFrom As Any, ByVal lSize As Long)
Private Declare Function HeapAlloc Lib "kernel32" (ByVal hHeap As Long, ByVal dwFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GetProcessHeap Lib "kernel32" () As Long
Private Declare Function HeapFree Lib "kernel32" (ByVal hHeap As Long, ByVal dwFlags As Long, lpMem As Any) As Long
Dim Ports(0 To 100) As PORT_INFO_2
Public Function TrimStr(strName As String) As String
'Finds a null then trims the string
Dim x As Integer
x = InStr(strName, vbNullChar)
If x > 0 Then TrimStr = Left(strName, x - 1) Else TrimStr = strName
End Function
Public Function LPSTRtoSTRING(ByVal lngPointer As Long) As String
Dim lngLength As Long
'Get number of characters in string
lngLength = lstrlenW(lngPointer) * 2
'Initialize string so we have something to copy the string into
LPSTRtoSTRING = String(lngLength, 0)
'Copy the string
CopyMem ByVal StrPtr(LPSTRtoSTRING), ByVal lngPointer, lngLength
'Convert to Unicode
LPSTRtoSTRING = TrimStr(StrConv(LPSTRtoSTRING, vbUnicode))
End Function
'Use ServerName to specify the name of a Remote Workstation I.e. "//WIN95WKST"
'or leave it blank "" to get the ports of the local Machine
Public Function GetAvailablePorts(ServerName As String) As Long
Dim ret As Long
Dim PortsStruct(0 To 100) As API_PORT_INFO_2
Dim pcbNeeded As Long
Dim pcReturned As Long
Dim TempBuff As Long
Dim I As Integer
'Get the amount of bytes needed to contain the data returned by the API call
ret = EnumPorts(ServerName, 2, TempBuff, 0, pcbNeeded, pcReturned)
'Allocate the Buffer
TempBuff = HeapAlloc(GetProcessHeap(), 0, pcbNeeded)
ret = EnumPorts(ServerName, 2, TempBuff, pcbNeeded, pcbNeeded, pcReturned)
If ret Then
'Convert the returned String Pointer Values to VB String Type
CopyMem PortsStruct(0), ByVal TempBuff, pcbNeeded
For I = 0 To pcReturned - 1
Ports(I).pDescription = LPSTRtoSTRING(PortsStruct(I).pDescription)
Ports(I).pPortName = LPSTRtoSTRING(PortsStruct(I).pPortName)
Ports(I).pMonitorName = LPSTRtoSTRING(PortsStruct(I).pMonitorName)
Ports(I).fPortType = PortsStruct(I).fPortType
Next
End If
GetAvailablePorts = pcReturned
'Free the Heap Space allocated for the Buffer
If TempBuff Then HeapFree GetProcessHeap(), 0, TempBuff
End Function
Private Sub Form_Load()
'KPD-Team 2000
'URL: http://www.allapi.net/
'E-Mail: KPDTeam@Allapi.net
Dim NumPorts As Long
Dim I As Integer
'Get the Numbers of Ports in the System
'and Fill the Ports Structure
NumPorts = GetAvailablePorts("")
'Show the available Ports
Me.AutoRedraw = True
For I = 0 To NumPorts - 1
Me.Print Ports(I).pPortName
Next
End Sub
Public Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long
Public Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long
Public Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Public Const KEY_QUERY_VALUE = &H1
Public Const HKEY_LOCAL_MACHINE = &H80000002
ret = RegOpenKeyEx(HKEY_LOCAL_MACHINE, "Hardware\DeviceMap\SerialComm", 0, KEY_QUERY_VALUE, dwResult)
strData = String$(255, 0)
cbData = Len(strData)
ret = RegQueryValueEx(dwResult, "COM2", ByVal 0, dwType, ByVal strData, cbData)
Com2Ok = (ret = 0 And Left(strData, cbData - 1) = "COM2")
ret = RegCloseKey(dwResult)
其实,只要加1句就够了:
完整的应该是:
Private Sub Command1_Click()
Dim i, j As Integer
j = 0
For i = 1 To 16
MSComm1.CommPort = i
On Error Resume Next
MSComm1.PortOpen = True
If Err.Number = 0 Then
j = j + 1
Else
MSComm1.PortOpen = False
End If
Next i
Label1.Caption = "您计算机上的串口数: " & j & "个"
Combo1.AddItem j ‘加了这句
End Sub
这是我的获取计算机串口的程序,你接着往下写拉(只要加个COMBOBOX控件,并把获得的串口数加到COMBOBOX中就行了) :)
Dim i, j As Integer
Private Sub Command1_Click()
j = 0
For i = 1 To 16
MSComm1.CommPort = i
On Error Resume Next
MSComm1.PortOpen = True
If Err.Number = 0 Then
j = j + 1
Else
MSComm1.PortOpen = False
End If
Next i
Label1.Caption = "您计算机上的串口数: " & j & "个"
End Sub