Private Const DEFAULT_QUEUE = 1024

Private Const DEFAULT_WAIT_TIME = 50



Private Const GENERIC_READ = &H80000000

Private Const GENERIC_WRITE = &H40000000

Private Const OPEN_EXISTING = 3              '

Private Const PURGE_RXABORT = &H2

Private Const PURGE_RXCLEAR = &H8



'Utils

Private Const SYNCHRONIZE = &H100000

Private Const STANDARD_RIGHTS_READ = &H20000

Private Const ERROR_SUCCESS = 0&

Private Const HKEY_LOCAL_MACHINE = &H80000002

Private Const KEY_ENUMERATE_SUB_KEYS = &H8

Private Const KEY_NOTIFY = &H10

Private Const KEY_QUERY_VALUE = &H1

Private Const KEY_READ = ((STANDARD_RIGHTS_READ Or KEY_QUERY_VALUE Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY) And (Not SYNCHRONIZE))

Private Const REG_DWORD = 4



'COM

Private Type COMMTIMEOUTS

        ReadIntervalTimeout As Long

        WriteTotalTimeoutConstant As Long

        ReadTotalTimeoutConstant As Long

        WriteTotalTimeoutMultiplier As Long

        ReadTotalTimeoutMultiplier As Long

End Type



Private Type COMSTAT

        fBitFields As Long

        cbInQue As Long

        cbOutQue As Long

End Type



Private Type DCB

    DCBlength As Long

    Baudrate As Long

    fBitFields As Long 'See Comments in Win32API.Txt

    wReserved As Integer

    XonLim As Integer

    XoffLim As Integer

    ByteSize As Byte

    Parity As Byte

    StopBits As Byte

    XOnChar As Byte

    XOffChar As Byte

    ErrorChar As Byte

    EofChar As Byte

    EvtChar As Byte

    wReserved1 As Integer 'Reserved; Do Not Use

End Type



Private Type OVERLAPPED

    ternal As Long

    hEvent As Long

    offset As Long

    OffsetHigh As Long

    ternalHigh As Long

End Type



Private Type SECURITY_ATTRIBUTES

        nLength As Long

        bInheritHandle As Long

        lpSecurityDescriptor As Long

End Type



'Common

Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

'COM

Private Declare Function BuildCommDCB Lib "kernel32" Alias "BuildCommDCBA" (ByVal lpDef As String, lpDCB As DCB) As Long

Private Declare Function ClearCommError Lib "kernel32" (ByVal hFile As Long, lpErrors As Long, lpStat As COMSTAT) As Long

Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long

Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, lpSecurityAttributes As SECURITY_ATTRIBUTES, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long

Private Declare Function GetCommState Lib "kernel32" (ByVal nCid As Long, lpDCB As DCB) As Long

Private Declare Function PurgeComm Lib "kernel32" (ByVal hFile As Long, ByVal dwFlags As Long) As Long

Private Declare Function ReadFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long, lpOverlapped As OVERLAPPED) As Long

Private Declare Function SetCommState Lib "kernel32" (ByVal hCommDev As Long, lpDCB As DCB) As Long

Private Declare Function SetCommTimeouts Lib "kernel32" (ByVal hFile As Long, lpCommTimeouts As COMMTIMEOUTS) As Long

Private Declare Function SetupComm Lib "kernel32" (ByVal hFile As Long, ByVal dwInQueue As Long, ByVal dwOutQueue As Long) As Long

Private Declare Function WriteFile Lib "kernel32" (ByVal hFile As Long, ByRef lpBuffer As Any, ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Long, lpOverlapped As OVERLAPPED) As Long

'Utils

Private 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

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 Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long



'Utils

Public Function EnumSerialPorts() As String  '枚举已存在的串口

    Dim hKey As Long, ID As Long, Result As String

    Dim Value As String, ValueLength As Long, Data As String, DataLength As Long

    Result = ""

    If RegOpenKeyEx(HKEY_LOCAL_MACHINE, "HARDWARE\DEVICEMAP\SERIALCOMM", 0&, KEY_READ, hKey) = ERROR_SUCCESS Then

        Do

            ValueLength = 2000

            DataLength = 2000

            Value = String(ValueLength, Chr(32))  '注册项

            Data = String(DataLength, Chr(32)) '值 Com 名称

            If RegEnumValue(hKey, ID, ByVal Value, ValueLength, 0&, REG_DWORD, ByVal Data, DataLength) = ERROR_SUCCESS Then

                Result = Result & IIf(Len(Result) = 0, "", ",") & Trim(Replace(Left(Data, DataLength), Chr(0), Chr(32)))

            Else

                Exit Do

            End If

            ID = ID + 1

        Loop

        RegCloseKey hKey

    End If

    EnumSerialPorts = Result

End Function



Public Function ArrToHex(ByRef Arr() As Byte) As String

    Dim I As Integer, Result As String

    For I = 0 To UBound(Arr)

        Result = Result & Right("0" & Hex(Arr(I)), 2)

    Next

    ArrToHex = Result

End Function



Public Function HexToArr(ByVal Data As String) As Byte()

    Dim C As Integer, I As Integer, Arr() As Byte, CH As String

    On Error GoTo hErr

    C = Len(Data) \ 2 - 1

    ReDim Arr(C)

    For I = 0 To C

        CH = Mid(Data, I * 2 + 1, 2)

        Arr(I) = CByte("&H" & CH)

    Next

    HexToArr = Arr

hErr:

End Function



'COM

Public Sub ComClose(ByRef Handle As Long)

    If Handle = -1 Then Exit Sub

    CloseHandle Handle

    Handle = -1

End Sub



Public Function ComOpen(ByVal Port As String, Optional ByVal Settings As String = "9600,n,8,1", Optional ByVal dwInQueue As Long = DEFAULT_QUEUE, Optional ByVal dwOutQueue As Long = DEFAULT_QUEUE) As Long

    Dim Result As Long, lpDCB As DCB, lpCommTimeouts As COMMTIMEOUTS, lpSA As SECURITY_ATTRIBUTES

    ComOpen = -1

    If IsNumeric(Port) Then

        Port = "\\.\Com" & Port

    Else

        Port = "\\.\" & Port

    End If

    Result = CreateFile(Port, GENERIC_READ Or GENERIC_WRITE, 0&, lpSA, OPEN_EXISTING, 0, 0&)

    If Result = -1 Then Exit Function

    If GetCommState(Result, lpDCB) = 0 Then

        CloseHandle Result

        Exit Function

    End If

    BuildCommDCB Settings, lpDCB

    If SetCommState(Result, lpDCB) = 0 Then

        CloseHandle Result

        Exit Function

    End If

    SetupComm Result, dwInQueue, dwOutQueue  '分配串口缓冲区

    '设定通讯超时参数

    lpCommTimeouts.ReadIntervalTimeout = 2

    lpCommTimeouts.ReadTotalTimeoutConstant = 4

    lpCommTimeouts.ReadTotalTimeoutMultiplier = 3

    lpCommTimeouts.WriteTotalTimeoutConstant = 5000 '一次写入串口数据的固定超时。

    lpCommTimeouts.WriteTotalTimeoutMultiplier = 50 '写入每字符间的超时。

    SetCommTimeouts Result, lpCommTimeouts

    ComOpen = Result

End Function



Public Function ComReadByte(ByVal Handle As Long, ByRef Result() As Byte, Optional ByVal WaitTime As Long = DEFAULT_WAIT_TIME) As Long

    Dim lpOverlapped As OVERLAPPED, lpStat As COMSTAT, lpErrors As Long

    If Handle = -1 Then Exit Function

    ComReadByte = 0

    If WaitTime > 0 Then Sleep WaitTime

    ClearCommError Handle, lpErrors, lpStat

    If lpStat.cbInQue > 0 Then

        ReDim Result(DEFAULT_QUEUE - 1) '设置缓冲区大小1K

        ReadFile Handle, Result(0), lpStat.cbInQue, ComReadByte, lpOverlapped

        If ComReadByte > 0 Then

            ReDim Preserve Result(ComReadByte - 1)

        Else

            Erase Result

        End If

    End If

End Function



Public Function ComWriteByte(ByVal Handle As Long, ByRef Data() As Byte) As Long

    Dim lpOverlapped As OVERLAPPED, lpErrors As Long, lpStat As COMSTAT

    If (Handle = -1) Or (Len(StrConv(Data, vbUnicode)) = 0) Then Exit Function

    PurgeComm Handle, PURGE_RXABORT Or PURGE_RXCLEAR  '清空输入缓冲区

    WriteFile Handle, Data(0), UBound(Data) + 1, ComWriteByte, lpOverlapped

    Do

        ClearCommError Handle, lpErrors, lpStat

    Loop Until lpStat.cbOutQue = 0  '等待输出结束

End Function



使用如下：

Dim hCom As Long,Data() As Byte

hCom=ComOpen("COM1","9600,n,8,1")

ComWriteByte hCom,HexToArr("8003000000054B1D")

ComReadByte hCom,Data

ComClose hCom'如果没有调用 ComClose hCom 而强制结束程序的话，你要重启VB程序才能工作

Debug.Print ArrToHex(Data)

有个需要通过串口 传递数据的 测量仪器！
通过串口测试软件测试发现，
若想要读取仪器测量值，必须先向设备 发送8个字节的查询命令，形如“80 03 00 00 00 05 4B 1D ” ,
才会返回一串21字节的数据，形如 80 03 10 01 00 03 23 00 00 00 00 00 00 00 00 00 00 00 00 48 4B 

取值过程如下：


现想通过VB利用mscomm组件实现数据读取，但不知道如何做。请大家帮个忙！！！