Траффик COM порта. Постоянные пробки на 4 и 7 контактах

[Bov]

Доброго врмени суток граждане VBStreets!!!

Есть несколько вопросов, надеюсь поможете (заранее очень благодарен):

1. Мне нужно получить список всех физических COM портов. (собственно не имею опыта, если бы можно получить название (описание) устройства которое подкуючено к этому порту.

2. Тоже самое только с виртуальными портами (USB to Serial и т.д.)

[Xcode]

Почитай тут
http://www.script-coding.info/WMI_HardWare.html
А причем тут трафик?

[Bov]

Спасибо за ссылку. В идеале нужны бы ещё писать трафик(данные) с портов в файл.

[Bov]

Спасибо за ссылку. В идеале нужны бы ещё писать трафик(данные) с портов в файл.

ещё бы кто помог в VB перевести данные коды:

Код: Выделить всё

On Error Resume Next
Set objService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\CIMV2")
If Err.Number <> 0 Then
   WScript.Echo Err.Number & ": " & Err.Description
   WScript.Quit
End If
For Each objPort In objService.ExecQuery("SELECT * FROM Win32_ParallelPort")
   WScript.Echo objPort.Caption 'наименование устройства
   WScript.Echo objPort.Description 'описание устройства
   WScript.Echo objPort.DeviceID 'идентификатор устройства
   WScript.Echo objPort.PNPDeviceID 'идентификатор устройства Plug-and-Play
   WScript.Echo objPort.SystemName 'имя компьютера
Next


Код: Выделить всё

On Error Resume Next
Set objService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\CIMV2")
If Err.Number <> 0 Then
   WScript.Echo Err.Number & ": " & Err.Description
   WScript.Quit
End If
For Each objPort In objService.ExecQuery("SELECT * FROM Win32_SerialPort")
   WScript.Echo objPort.Caption 'наименование устройства
   WScript.Echo objPort.Description 'описание устройства
   WScript.Echo objPort.DeviceID 'идентификатор устройства
   WScript.Echo objPort.PNPDeviceID 'идентификатор устройства Plug-and-Play
   WScript.Echo objPort.SystemName 'имя компьютера
   WScript.Echo
Next


[NashRus]

юзай SetupAPI.
а вот еще было бы хорошо понять какой процесс юзает конкретный занятый порт...?

[Penumbra]

вот кусок кода

Код: Выделить всё

Sub VerifyPorts()
    Dim sPort As String
    Dim iX As Long
    Dim iY As Long
    Dim lngType As Long
    Dim lngValue As Long
    Dim sName As String
    Dim sSwap As String
    ReDim varResult(0 To 1, 0 To 100) As Variant
    Const lNameLen As Long = 260
    Const lDataLen As Long = 4096
Dim sSubKey As String

        sSubKey = "Hardware\Devicemap\SerialComm"
        If RegOpenKeyEx(lMainKey, sSubKey, 0, KEY_READ, hnd) Then Exit Sub
            For iX = 0 To 999999
                If iX > UBound(varResult, 2) Then
                    ReDim Preserve varResult(0 To 1, iX + 99)
                End If
                sName = Space$(lNameLen)
                ReDim binValue(0 To lDataLen - 1) As Byte
                If RegEnumValue(hnd, iX, sName, lNameLen, ByVal 0&, lngType, binValue(0), lDataLen) Then Exit For
                    varResult(0, iX) = Left$(sName, lNameLen)
                   
                    Select Case lngType
                        Case REG_DWORD
                            CopyMemory lngValue, binValue(0), 4
                            varResult(1, iX) = lngValue
                        Case REG_SZ
                            varResult(1, iX) = Left$(StrConv(binValue(), vbUnicode), lDataLen - 1)
                        Case Else
                            ReDim Preserve binValue(0 To lDataLen - 1) As Byte
                            varResult(1, iX) = binValue()
                    End Select
            Next
        If hnd Then RegCloseKey hnd                                             'Close The Registry Key
        ReDim Preserve varResult(0 To 1, iX - 1) As Variant
        ReDim Ports(iX - 1)
        For iX = 0 To UBound(varResult, 2)                                      'Trim 'Port' To Get Just The Number
            sPort = Mid$(varResult(1, iX), 4, 1)
            Ports(iX) = sPort
        Next

        iY = UBound(Ports)                                                       'Arrange The Ports Numbers Low To High
        For iX = 0 To (iY - 1)
            If Ports(iX + 1) < Ports(iX) Then
                sSwap = Ports(iX + 1)
                Ports(iX + 1) = Ports(iX)
                Ports(iX) = sSwap
                iX = -1
            End If
        Next

End Sub

[Xcode]

ещё бы кто помог в VB перевести данные коды: ...

Код: Выделить всё

On Error Resume Next
Set objService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\CIMV2")
If Err.Number <> 0 Then
   Print Err.Number & ": " & Err.Description
   Exit Sub
End If
For Each objPort In objService.ExecQuery("SELECT * FROM Win32_ParallelPort")
   Print objPort.Caption 'наименование устройства
   Print objPort.Description 'описание устройства
   Print objPort.DeviceID 'идентификатор устройства
   Print objPort.PNPDeviceID 'идентификатор устройства Plug-and-Play
   Print objPort.SystemName 'имя компьютера
Next

Дальше по аналогии.

[Bov]

Всем спасибо!!

[SeT]

Была похожая проблема, но мне были нужны ещё и USB-устройства.

Вот решение:

Код: Выделить всё

Public Const ERROR_NO_MORE_ITEMS = 259&
Public Const HKEY_CURRENT_CONFIG = &H80000005
Public Const HKEY_LOCAL_MACHINE = &H80000002
Public Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Public Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Public 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
Public 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 Any, lpcbData As Long) As Long
Public Function com_list() As String
    Dim result As String
    Dim hKey As Long, Cnt As Long, sName As String, sData As String, Ret As Long, RetData As Long
    Const BUFFER_SIZE As Long = 255
   
    Ret = BUFFER_SIZE
    Cnt = 0
    'Open a registry key
    If RegOpenKey(HKEY_LOCAL_MACHINE, "HARDWARE\DEVICEMAP\SERIALCOMM", hKey) = 0 Then
        'initialize
        sName = Space(BUFFER_SIZE)
        sData = Space(BUFFER_SIZE)
        Ret = BUFFER_SIZE
        RetData = BUFFER_SIZE
        'enumerate the values
        While RegEnumValue(hKey, Cnt, sName, Ret, 0, ByVal 0&, ByVal sData, RetData) <> ERROR_NO_MORE_ITEMS
            'show data
            If RetData > 0 Then result = result + Left$(sData, RetData - 1) + "|"
                'Me.Print "  " + Left$(sName, Ret) + "=" + Left$(sData, RetData - 1)

            'prepare for next value
            Cnt = Cnt + 1
            sName = Space(BUFFER_SIZE)
            sData = Space(BUFFER_SIZE)
            Ret = BUFFER_SIZE
            RetData = BUFFER_SIZE
        Wend
        'Close the registry key
        RegCloseKey hKey
    Else
    End If
    com_list = result
End Function

Использование:

Код: Выделить всё

 
Dim a() As String
Dim temp as string 
 
temp = com_list
a = Split(temp, "|")

Получаем массив с элементами "COM1","COM2","COM3" и так далее