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