VB6.0 API串口接收/发送数据及设置

Option Explicit

Public PortMemory As String Public AllBlueMemory As String Public BlueMemory As String

Private Type COMSTAT

    fBitFields As Long

   COMSTAT   cbInQue As Long

   cbOutQue As Long

End Type

Private Type COMMTIMEOUTS

    ReadIntervalTimeout As Long

    ReadTotalTimeoutMultiplier As Long

    ReadTotalTimeoutConstant As Long

    WriteTotalTimeoutMultiplier As Long

    WriteTotalTimeoutConstant As Long

End Type

Private Type DCB

    DCBlength As Long

    BaudRate As Long

    fBitFields As Long

    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

End Type

Private Type OVERLAPPED

    Internal As Long

    InternalHigh As Long

    offset As Long

    OffsetHigh As Long

    hEvent As Long

End Type

Private Type SECURITY_ATTRIBUTES

    nLength As Long

    lpSecurityDescriptor As Long

    bInheritHandle As Long

End Type

Public Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long

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

Public Declare Function TerminateProcess Lib "kernel32" (ByVal hProcess As Long, ByVal uExitCode As Long) As Long

Private Declare Function GetLastError Lib "kernel32" () 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 WriteFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Long, lpOverlapped As OVERLAPPED) As Long 'OVERLAPPED

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

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

Private Declare Function GetOverlappedResult Lib "kernel32" (ByVal hFile As Long, lpOverlapped As OVERLAPPED, lpNumberOfBytesTransferred As Long, ByVal bWait As Long) As Long

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

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

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

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

Private Declare Function FlushFileBuffers Lib "kernel32" (ByVal hFile As Long) As Long

Private Declare Function CreateEvent Lib "kernel32" Alias "CreateEventA" (lpEventAttributes As SECURITY_ATTRIBUTES, ByVal bManualReset As Long, ByVal bInitialState As Long, ByVal lpName As String) As Long

Private Declare Function SetCommMask Lib "kernel32" (ByVal hFile As Long, ByVal dwEvtMask As Long) As Long

Private Declare Function SetEvent Lib "kernel32" (ByVal hEvent As Long) 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 PurgeComm Lib "kernel32" (ByVal hFile As Long, ByVal dwFlags As Long) As Long

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

Private Declare Function WaitCommEvent Lib "kernel32 " (ByVal hFile As Long, lpEvtMask As Long, lpOverlapped As OVERLAPPED) As Long

Private Declare Function ResetEvent Lib "kernel32 " (ByVal hFile As Long) As Long

Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long Private Declare Function GetTickCount Lib "kernel32" () As Long

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

Private Const INVALID_HANDLE_VALUE = -1

Private Const GENERIC_WRITE = &H40000000

Private Const GENERIC_READ = &H80000000

Private Const OPEN_EXISTING = 3

Private Const FILE_ATTRIBUTE_NORMAL = &H80

Private Const FILE_FLAG_OVERLAPPED = &H40000000

Private Const DTR_CONTROL_DISABLE = &H0

Private Const RTS_CONTROL_ENABLE = &H1

Private Const PURGE_RXABORT = &H2

Private Const PURGE_RXCLEAR = &H8

Private Const PURGE_TXABORT = &H1

Private Const PURGE_TXCLEAR = &H4

Private Const ERROR_IO_PENDING = 997

Private Const STATUS_WAIT_0 = &H0

Private Const WAIT_OBJECT_0 = (STATUS_WAIT_0 + 0)

Private Const WAIT_TIMEOUT = 258&

Public Const PROCESS_QUERY_INFORMATION = &H400

Public Const PROCESS_TERMINATE = &H1

Private Const EV_RXCHAR = &H1                '  Any Character received

Private m_OverlappedRead As OVERLAPPED

Private m_OverlappedWrite As OVERLAPPED

Private com_Handle As Long

Private com_RxBy As Long Private com_TxBy As Long

Public Property Get ReceivedByte() As Long    

ReceivedByte = com_RxBy

End Property

Public Property Get SendedByte() As Long

    SendedByte = com_TxBy

End Property

Public Property Let ReceivedByte(X As Long)    

com_RxBy = 0

End Property

Public Property Let SendedByte(X As Long)    

com_TxBy = 0

End Property

Public Property Get Handle() As Long

    Handle = com_Handle

End Property

'Public Property Let Handle(id As Long)

'    com_Handle = id 'End Property

'*************************************************************************

'**函 数 名：OpenPort '**ComPort:形式如：COM1、COM2、LPT1等等

'**Comsettings：形式如："9600,n,8,1"

'**lngInSize:写入缓冲区大小

'**lngOutSize:写出缓冲区大小

'*************************************************************************

Public Function OpenPort(ComPort As String, Comsettings As String, Optional lngInSize As Long = 1024, Optional lngOutSize As Long = 1024) As Long   

  On Error GoTo handelinitcom    

Dim RetVal As Long     '定义标志值   

  Dim flag As Long

    '定义设备控制块  

   Dim typDCB As DCB

    Dim CtimeOut As COMMTIMEOUTS, dcbs As DCB

    Dim strCOM As String, strConfig As String

    '    strCOM = "COM" & Format(ComNumber, "0")     strCOM = ComPort

    '    Com_Handle = CreateFile(strCOM, GENERIC_READ Or GENERIC_WRITE, 0, ByVal 0, _        

  '                 OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL Or FILE_FLAG_OVERLAPPED, 0)

    com_Handle = CreateFile(strCOM, _

            GENERIC_READ Or GENERIC_WRITE, 0, ByVal 0, _  

           OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL Or FILE_FLAG_OVERLAPPED, 0)

    If com_Handle = INVALID_HANDLE_VALUE Then

        OpenPort = -1   

      Exit Function

    End If

    '********获取出错信息********

    Dim errNum As Long     errNum = GetLastError()   

  '    Debug.Print "出错信息：" & errNum

    '********获取设备控制块********   

  flag = GetCommState(com_Handle, typDCB)  

   '    Debug.Print "获取串口DCB：" & flag       

Dim SetDb() As String

    SetDb = Split(Comsettings, ",")

    If UBound(SetDb) >= 3 Then

        typDCB.BaudRate = CLng(SetDb(0))

                             '定义波特率        

If UCase(SetDb(1)) = "N" Then

                                    'NOPARITY

           typDCB.Parity = 0     

                               'NOPARITY                               '无校验位

        Else           

typDCB.Parity = 1        

End If        

typDCB.ByteSize = CByte(SetDb(2))  '数据位

               typDCB.StopBits = CByte(SetDb(3))'停止位 0/1/2 = 1/1.5/2   

  Else        

typDCB.BaudRate = 460800  '定义波特率        

typDCB.Parity = 0   'NOPARITY  '无校验位        

typDCB.ByteSize = 8  '数据位        

typDCB.StopBits = 0  '停止位 0/1/2 = 1/1.5/2     End If  

    '********设置串口参数********

    flag = SetCommState(com_Handle, typDCB)     '    Debug.Print "设置串口参数：" & flag

    '********设置缓冲区大小********   

  flag = SetupComm(com_Handle, lngInSize, lngOutSize)     '    flag = SetupComm(com_Handle, 8192, 8192)

    CtimeOut.ReadIntervalTimeout = -1                      '0

    CtimeOut.ReadTotalTimeoutConstant = 0                  '2500

    CtimeOut.ReadTotalTimeoutMultiplier = 0               '0

    CtimeOut.WriteTotalTimeoutConstant = 0             '20  '2500

    CtimeOut.WriteTotalTimeoutMultiplier = 0            '200  '0    

'********超时设置********    

flag = SetCommTimeouts(com_Handle, CtimeOut)

    flag = SetCommMask(com_Handle, EV_RXCHAR)              '设置监视的事件为接收到字符   

  '********清空读写缓冲区********  

   Call PurgeComm(com_Handle, PURGE_RXABORT Or PURGE_RXCLEAR Or PURGE_TXABORT Or PURGE_TXCLEAR)    '清除缓冲区

    If flag = -1 Then        

RetVal = GetLastError()

        OpenPort = flag

        RetVal = CloseHandle(com_Handle)

        Exit Function

    End If

    '获取信号句柄  

   Dim lpEventAttributes1 As SECURITY_ATTRIBUTES

    Dim lpEventAttributes2 As SECURITY_ATTRIBUTES

    m_OverlappedRead.hEvent = CreateEvent(lpEventAttributes1, 1, 0, 0)     m_OverlappedWrite.hEvent = CreateEvent(lpEventAttributes2, 1, 0, 0)

    '判断设置参数是否成功   设置输入和输出缓冲区是否成功

    If m_OverlappedRead.hEvent = 0 Or m_OverlappedWrite.hEvent = 0 Then

        RetVal = GetLastError()  

       OpenPort = RetVal

        If (m_OverlappedRead.hEvent <> 0) Then

CloseHandle (m_OverlappedRead.hEvent)

        If (m_OverlappedWrite.hEvent <> 0) Then

CloseHandle (m_OverlappedWrite.hEvent)

        Call CloseHandle(com_Handle)  

       com_Handle = 0       

  Exit Function   

  End If

    OpenPort = 0  

   Exit Function

handelinitcom:    

Call CloseHandle(com_Handle)

    com_Handle = 0    

OpenPort = -1    

Exit Function

End Function

'*************************************************************************

'**函 数 名：ClosePort

'*************************************************************************

Public Function ClosePort() As Long

    If com_Handle = INVALID_HANDLE_VALUE Then

        Exit Function

    End If

    Call SetCommMask(com_Handle, 0)

    Call SetEvent(m_OverlappedRead.hEvent)

    Call SetEvent(m_OverlappedWrite.hEvent)

    If (m_OverlappedRead.hEvent <> 0) Then

CloseHandle (m_OverlappedRead.hEvent)

    If (m_OverlappedWrite.hEvent <> 0) Then

CloseHandle (m_OverlappedWrite.hEvent)

    If CloseHandle(com_Handle) <> 0 Then

        ClosePort = 0    

Else        

ClosePort = -1    

End If

    com_Handle = INVALID_HANDLE_VALUE

    frmConnection.CHUANKOUFLAG = 0

End Function

'*************************************************************************

'**函 数 名：ClearInBuf

'**输    入：无

'**输    出：无

'**功能描述：清空输入缓冲区

'*************************************************************************

Public Function ClearInBuf() As Long   

  If (com_Handle = INVALID_HANDLE_VALUE) Then

        ClearInBuf = 1        

Exit Function    

End If    

Call PurgeComm(com_Handle, PURGE_RXABORT Or PURGE_RXCLEAR)

    ClearInBuf = 0

End Function

'*************************************************************************

'**函 数 名：ClearOutBuf

'**输    入：无

'**输    出：(Long) -

'**功能描述：清空输出缓冲区

'*************************************************************************

Public Function ClearOutBuf() As Long

    If (com_Handle = INVALID_HANDLE_VALUE) Then

        ClearOutBuf = 1

        Exit Function

    End If    

Call PurgeComm(com_Handle, PURGE_TXABORT Or PURGE_TXCLEAR)

    ClearOutBuf = 0

End Function

'*************************************************************************

'**函 数 名：SendData

'**输    入：bytBuffer()(Byte) - 数据

'**        ：lngSize(Long) - 数据长度

'**输    出：(Long) -

'**功能描述：发送数据

'*************************************************************************

Public Function SendData(bytBuffer() As Byte, lngSize As Long) As Long

    On Error GoTo Routine_Exit                                   '打开错误陷阱

    Dim errNum As Long    

Dim flag As Long    

Dim i As Long   

  If (com_Handle = 0) Then

        SendData = 1

        Exit Function

    End If

    Dim dwBytesWritten As Long

    Dim bWriteStat As Long

    Dim ComStats As COMSTAT

    Dim dwErrorFlags As Long

    '    dwBytesWritten = lngSize

    Call ClearCommError(com_Handle, dwErrorFlags, ComStats)

    bWriteStat = WriteFile(com_Handle, bytBuffer(0), lngSize, dwBytesWritten, m_OverlappedWrite)     '>>正常编译时候就这样就可以了

    Call GetOverlappedResult(com_Handle, m_OverlappedWrite, dwBytesWritten, 1)   

'等待直到发送完毕    

'<<正常编译时候就这样就可以了    

'    ''>>这样在调试状态下可以的或在编译为P代码的情况下是可以正常运行    

'    If Not bWriteStat Then    

'        If GetLastError() = ERROR_IO_PENDING Then    

'            Call GetOverlappedResult(com_Handle, m_OverlappedWrite, dwBytesWritten, 1)    '等待直到发送完毕    

'        End If    

'    End If    

'    ''<<这样在调试状态下可以的或在编译为P代码的情况下是可以正常运行

    com_TxBy = com_TxBy + dwBytesWritten

    SendData = dwBytesWritten

    ClearOutBuf                                            '清除缓冲区

    ''   

'发送数据     ''   

For i = 0 To UBound(bytBuffer)     '' 

       flag = WriteFile(Com_Handle, bytBuffer(i), 1, dwBytesWritten, m_OverlappedWrite)    

''        If Not flag Then

    ''            '获取出错码     '' 

           errNum = GetLastError()     ''  

          If (errNum = ERROR_IO_PENDING) Then     '' 

               flag = 0     ''

                flag = GetOverlappedResult(Com_Handle, m_OverlappedWrite, dwBytesWritten, 1)     '' 

               SendData = SendData + dwBytesWritten     '' 

               Debug.Print "errNum = ERROR_IO_PENDING"     ''

            Else     ''           

End If     ''       

End If     ''     ''        '        '间隔时间（用于需要设定每字节间间隔时间的发送协议）     ''        '                Sleep (intIntervalTime)     ''    Next

Exit Function     '----------------

Routine_Exit:

    SendData = -1

End Function

'*************************************************************************

'**函 数 名：ReadData

'**输    入：bytBuffer()(Byte) - 读取到的数据

'**        ：Outtime(Long)     - 等待时间ms

'**输    出：(Long) -读取的字节数量

'**功能描述：读取数据 '*************************************************************************

'Public Function ReadData(bytBuffer() As Byte, lngSize As Long, Optional Outtime As Long = 2000) As Long

Public Function ReadData(bytBuffer() As Byte, Optional lngSize As Long = 255, Optional Outtime As Long = 2000) As Long

    On Error GoTo Routine_Exit                                   '打开错误陷阱

    If (com_Handle = 0) Then

        ReadData = 0

        Exit Function

    End If

    Dim lngBytesRead As Long

    Dim fReadStat As Long

    Dim dwRes  As Long

    Dim lngErrorFlags As Long

    Dim lngStatus As Long

    Dim udtCommStat As COMSTAT

    Dim evtMask As Long

    Dim ret As Long

'        lngBytesRead = lngSize

'    清除之前的一切错误与获取当前的状态

    lngStatus = ClearCommError(com_Handle, lngErrorFlags, _             udtCommStat)

        Debug.Print "udtCommStat.cbInQue " & udtCommStat.cbInQue

'    读数据    

If lngStatus <> 0 And udtCommStat.cbInQue > 0 And lngSize > 0 Then

        If lngSize = 255 And udtCommStat.cbInQue > 255 Then

            lngSize = udtCommStat.cbInQue

        End If

        ReDim Preserve bytBuffer(lngSize) As Byte

        fReadStat = ReadFile(com_Handle, bytBuffer(0), lngSize, lngBytesRead, m_OverlappedRead)

        com_RxBy = com_RxBy + lngBytesRead

        If fReadStat = 0 Then

            Call PurgeComm(com_Handle, PURGE_RXABORT Or PURGE_RXCLEAR Or PURGE_TXABORT Or PURGE_TXCLEAR)    '清除缓冲区

'                    lngStatus = GetLastError

'                    If lngStatus = ERROR_IO_PENDING Then

'                           Call PurgeComm(com_Handle, PURGE_RXABORT Or PURGE_RXCLEAR Or PURGE_TXABORT Or PURGE_TXCLEAR) '清除缓冲区

'                    Else

'                       

' Some other error occurred.

'                        lngBytesRead = -1

'                       

'                lngStatus = SetCommErrorEx("CommRead (ReadFile)", _

'                                                     

'                        Com_Handle)

'                        GoTo Routine_Exit

'                    End If        

End If

        ClearInBuf                                         '清除缓冲区

    End If    

ReadData = lngBytesRead

    Exit Function

Routine_Exit:

    ReadData = 0

End Function

'*************************************************************************

'**函 数 名：Class_Initialize

'*************************************************************************

Private Sub Class_Initialize()

   com_Handle = INVALID_HANDLE_VALUE

   com_RxBy = 0

   com_TxBy = 0

End Sub

'*************************************************************************

'**函 数 名：Class_Terminate

'*************************************************************************

Private Sub Class_Terminate()

    Call ClosePort

End Sub