'*************************************************************************'**模 块 名：SPort'**by zdt 20081110'**用API 对Com进行操作'*************************************************************************Option Explicit
'Private Type COMSTAT'    fCtsHold As Long'    fDsrHold As Long'    fRlsdHold As Long'    fXoffHold As Long'    fXoffSent As Long'    fEof As Long'    fTxim As Long'    fReserved As Long'    cbInQue As Long'    cbOutQue As Long'End Type
Private Type COMSTAT    fBitFields As Long                                     ' See Comment in Win32API.Txt COMSTAT    cbInQue As Long    cbOutQue As LongEnd Type
Private Type COMMTIMEOUTS    ReadIntervalTimeout As Long    ReadTotalTimeoutMultiplier As Long    ReadTotalTimeoutConstant As Long    WriteTotalTimeoutMultiplier As Long    WriteTotalTimeoutConstant As LongEnd 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 UseEnd Type
Private Type OVERLAPPED    Internal As Long    InternalHigh As Long    offset As Long    OffsetHigh As Long    hEvent As LongEnd Type
Private Type SECURITY_ATTRIBUTES    nLength As Long    lpSecurityDescriptor As Long    bInheritHandle As LongEnd Type
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As LongPrivate Declare Function GetLastError Lib "kernel32" () As LongPrivate Declare Function ReadFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long, lpOverlapped As OVERLAPPED) As LongPrivate Declare Function WriteFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Long, lpOverlapped As OVERLAPPED) As Long 'OVERLAPPEDPrivate Declare Function SetCommTimeouts Lib "kernel32" (ByVal hFile As Long, lpCommTimeouts As COMMTIMEOUTS) As LongPrivate Declare Function GetCommTimeouts Lib "kernel32" (ByVal hFile As Long, lpCommTimeouts As COMMTIMEOUTS) As LongPrivate Declare Function GetOverlappedResult Lib "kernel32" (ByVal hFile As Long, lpOverlapped As OVERLAPPED, lpNumberOfBytesTransferred As Long, ByVal bWait As Long) As LongPrivate Declare Function BuildCommDCB Lib "kernel32" Alias "BuildCommDCBA" (ByVal lpDef As String, lpDCB As DCB) As LongPrivate Declare Function SetCommState Lib "kernel32" (ByVal hCommDev As Long, lpDCB As DCB) As LongPrivate Declare Function GetCommState Lib "kernel32" (ByVal nCid As Long, lpDCB As DCB) As LongPrivate 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 LongPrivate Declare Function FlushFileBuffers Lib "kernel32" (ByVal hFile As Long) As LongPrivate Declare Function CreateEvent Lib "kernel32" Alias "CreateEventA" (lpEventAttributes As SECURITY_ATTRIBUTES, ByVal bManualReset As Long, ByVal bInitialState As Long, ByVal lpName As String) As LongPrivate Declare Function SetCommMask Lib "kernel32" (ByVal hFile As Long, ByVal dwEvtMask As Long) As LongPrivate Declare Function SetEvent Lib "kernel32" (ByVal hEvent As Long) As LongPrivate Declare Function SetupComm Lib "kernel32" (ByVal hFile As Long, ByVal dwInQueue As Long, ByVal dwOutQueue As Long) As LongPrivate Declare Function PurgeComm Lib "kernel32" (ByVal hFile As Long, ByVal dwFlags As Long) As LongPrivate Declare Function ClearCommError Lib "kernel32" (ByVal hFile As Long, lpErrors As Long, lpStat As COMSTAT) As LongPrivate Declare Function WaitCommEvent Lib "kernel32 " (ByVal hFile As Long, lpEvtMask As Long, lpOverlapped As OVERLAPPED) As LongPrivate 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 LongPrivate Declare Function GetTickCount Lib "kernel32" () As LongPrivate Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Const INVALID_HANDLE_VALUE = -1Private Const GENERIC_WRITE = &H40000000Private Const GENERIC_READ = &H80000000Private Const OPEN_EXISTING = 3Private Const FILE_ATTRIBUTE_NORMAL = &H80Private Const FILE_FLAG_OVERLAPPED = &H40000000Private Const DTR_CONTROL_DISABLE = &H0Private Const RTS_CONTROL_ENABLE = &H1Private Const PURGE_RXABORT = &H2Private Const PURGE_RXCLEAR = &H8Private Const PURGE_TXABORT = &H1Private Const PURGE_TXCLEAR = &H4Private Const ERROR_IO_PENDING = 997Private Const STATUS_WAIT_0 = &H0Private Const WAIT_OBJECT_0 = (STATUS_WAIT_0 + 0)Private Const WAIT_TIMEOUT = 258&
Private Const EV_RXCHAR = &H1                '  Any Character received
Private m_OverlappedRead As OVERLAPPEDPrivate m_OverlappedWrite As OVERLAPPED
Private com_Handle As LongPrivate com_RxBy As LongPrivate com_TxBy As Long
Public Property Get ReceivedByte() As Long    ReceivedByte = com_RxByEnd PropertyPublic Property Get SendedByte() As Long    SendedByte = com_TxByEnd Property
Public Property Let ReceivedByte(x As Long)    com_RxBy = 0End PropertyPublic Property Let SendedByte(x As Long)    com_TxBy = 0End Property
Public Property Get Handle() As Long    Handle = com_HandleEnd 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 = 9600                             '定义波特率        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 Functionhandelinitcom:    Call CloseHandle(com_Handle)    com_Handle = 0    OpenPort = -1    Exit FunctionEnd 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_VALUEEnd 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 = 0End 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 = 0End 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 = -1End Function
'*************************************************************************'**函 数 名：ReadData'**输    入：bytBuffer()(Byte) - 读取到的数据'**        ：Outtime(Long)     - 等待时间ms'**输    出：(Long) -读取的字节数量'**功能描述：读取数据'*************************************************************************'Public Function ReadData(bytBuffer() As Byte, lngSize As Long, Optional Outtime As Long = 2000) As LongPublic 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 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 FunctionRoutine_Exit:    ReadData = 0End Function'*************************************************************************'**函 数 名：Class_Initialize'*************************************************************************Private Sub Class_Initialize()   com_Handle = INVALID_HANDLE_VALUE   com_RxBy = 0   com_TxBy = 0End Sub
'*************************************************************************'**函 数 名：Class_Terminate'*************************************************************************Private Sub Class_Terminate()    Call ClosePortEnd Sub