VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "SerialPort"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'*************************************************************************
'**模 塊 名：SerialPort
'**說    明：YFsoft 版權所有2006 - 2007(C)
'**創 建 人：葉帆
'**日    期：2006-08-17 14:32:29
'**修 改 人：
'**日    期：
'**描    述：串口異步讀寫(API)
'**版    本：V1.0.0
'*************************************************************************
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 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
    'DWORD DCBlength;      /* sizeof(DCB)                     */
    'DWORD BaudRate;       /* Baudrate at which running       */
    'DWORD fBinary: 1;     /* Binary Mode (skip EOF check)    */
    'DWORD fParity: 1;     /* Enable parity checking          */
    'DWORD fOutxCtsFlow:1; /* CTS handshaking on output       */
    'DWORD fOutxDsrFlow:1; /* DSR handshaking on output       */
    'DWORD fDtrControl:2;  /* DTR Flow control                */
    'DWORD fDsrSensitivity:1; /* DSR Sensitivity              */
    'DWORD fTXContinueOnXoff: 1; /* Continue TX when Xoff sent */
    'DWORD fOutX: 1;       /* Enable output X-ON/X-OFF        */
    'DWORD fInX: 1;        /* Enable input X-ON/X-OFF         */
    'DWORD fErrorChar: 1;  /* Enable Err Replacement          */
    'DWORD fNull: 1;       /* Enable Null stripping           */
    'DWORD fRtsControl:2;  /* Rts Flow control                */
    'DWORD fAbortOnError:1; /* Abort all reads and writes on Error */
    'DWORD fDummy2:17;      /* Reserved                        */
    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
    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

Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject 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 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 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 GetOverlappedResult Lib "kernel32" (ByVal hFile As Long, lpOverlapped As OVERLAPPED, lpNumberOfBytesTransferred As Long, ByVal bWait As Long) As Long
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds 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 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&

Private m_Handle As Long
Private m_OverlappedRead As OVERLAPPED
Private m_OverlappedWrite As OVERLAPPED

'*************************************************************************
'**函 數 名：OpenPort
'**輸    入：ComNumber(Long)     - 串口號
'**        ：Comsettings(String) - 配置信息
'**輸    出：(Long) - 0 成功 非 0 失敗
'**功能描述：打開串口
'**全局變量：
'**調用模塊：
'**作    者：葉帆
'**日    期：2006-08-17 14:40:14
'**修 改 人：
'**日    期：
'**版    本：V1.0.0
'*************************************************************************
Public Function OpenPort(ComNumber As Long, Comsettings As String, Optional lngInSize As Long = 1024, Optional lngOutSize As Long = 512) As Long
    On Error GoTo handelinitcom
    Dim retval As Long
    Dim CtimeOut As COMMTIMEOUTS, dcbs As DCB
    Dim strCOM As String, strConfig As String

    strCOM = "COM" & Format(ComNumber, "0")
    m_Handle = CreateFile(strCOM, GENERIC_READ Or GENERIC_WRITE, 0, 0&, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL Or FILE_FLAG_OVERLAPPED, 0)
    If m_Handle = -1 Then
        OpenPort = -1
        Exit Function
    End If

    '設置dcb塊
    dcbs.DCBlength = Len(dcbs)                           '長度
    Call GetCommState(m_Handle, dcbs)

    '波特率,奇偶校驗,數據位,停止位  如：9600,n,8,1
    strConfig = "COM" & Format(ComNumber, "0") & ":" & Comsettings
    Call BuildCommDCB(strConfig, dcbs)

    '------------------------------
    '    dcbs.fBinary = 1                          '二進制方式
    '    dcbs.fOutxCtsFlow = 0                     '不用CTS檢測發送流控制
    '    dcbs.fOutxDsrFlow = 0                     '不用DSR檢測發送流控制
    '    dcbs.fDtrControl = DTR_CONTROL_DISABLE    '禁止DTR流量控制
    '    dcbs.fDsrSensitivity = 0                  '對DTR信號線不敏感
    '    dcbs.fTXContinueOnXoff = 1                '檢測接收緩沖區
    '    dcbs.fOutX = 0                            '不做發送字符控制
    '    dcbs.fInX = 0                             '不做接收控制
    '    dcbs.fErrorChar = 0                       '是否用指定字符替換校驗錯的字符
    '    dcbs.fNull = 0                            '保留NULL字符
    '    dcbs.fRtsControl = RTS_CONTROL_ENABLE     '允許RTS流量控制
    '    dcbs.fAbortOnError = 0                    '發送錯誤后，繼續進行下面的讀寫操作
    '    dcbs.fDummy2 = 0                          '保留
    dcbs.fBitFields = 1 * 2 ^ 0 Or DTR_CONTROL_DISABLE * 2 ^ 4 Or 1 * 2 ^ 7 Or RTS_CONTROL_ENABLE * 2 ^ 12

    dcbs.wReserved = 0                        '沒有使用，必須為0
    dcbs.XonLim = 0                           '指定在XOFF字符發送之前接收到緩沖區中可允許的最小字節數
    dcbs.XoffLim = 0                          '指定在XOFF字符發送之前緩沖區中可允許的最小可用字節數
    dcbs.XonChar = 0                          '發送和接收的XON字符
    dcbs.XoffChar = 0                         '發送和接收的XOFF字符
    dcbs.ErrorChar = 0                        '代替接收到奇偶校驗錯誤的字符
    dcbs.EofChar = 0                          '用來表示數據的結束
    dcbs.EvtChar = 0                          '事件字符，接收到此字符時，會產生一個事件
    'dcbs.wReserved1 = 0                      '沒有使用
    'dcbs.BaudRate =9600                      '波特率
    'dcbs.Parity=0                            '奇偶校驗
    'dcbs.ByteSize=8                          '數據位
    'dcbs.StopBits=0                          '停止位
    '------------------------------

    If dcbs.Parity = 0 Then                   ' 0-4=None,Odd,Even,Mark,Space
        dcbs.fBitFields = dcbs.fBitFields And &HFFFD     'dcbs.fParity = 0                      '奇偶校驗無效
    Else
        dcbs.fBitFields = dcbs.fBitFields Or &H2         'dcbs.fParity = 1                      '奇偶校驗有效
    End If

    '超時設置
    CtimeOut.ReadIntervalTimeout = 20                  '0
    CtimeOut.ReadTotalTimeoutConstant = 1              '2500
    CtimeOut.ReadTotalTimeoutMultiplier = 1            '0
    CtimeOut.WriteTotalTimeoutConstant = 10            '2500
    CtimeOut.WriteTotalTimeoutMultiplier = 1           '0
    
    retval = SetCommTimeouts(m_Handle, CtimeOut)

    If retval = -1 Then
        retval = GetLastError()
        OpenPort = retval
        retval = CloseHandle(m_Handle)
        Exit Function
    End If

    '獲取信號句柄
    Dim lpEventAttributes1 As SECURITY_ATTRIBUTES
    Dim lpEventAttributes2 As SECURITY_ATTRIBUTES