Attribute VB_Name = "SerialPort"
'==================================================
' Serial port driver for Visual Basic Ver4.0
' Copyright(C) IWATSU ELECTRIC Co., LTD. 1996,97,98
' Ver. 1998/03/27,
' Code by T.Torii Customer Service Dept.TME div.
'==================================================

Option Explicit
Public CommLineDelim(1) As Byte ' Line delimiter {LF,0} etc.
Public CommLineDelimLen As Long ' length of Line delimiter
Public CommDataDelim(3) As Byte ' Data delimiter "," etc
Public CommLastByte As Byte     ' Last Received byte
Public CommCount As Long        ' Send or received byte.
Public CommAbort As Boolean     ' Abort Flag
Public CommError As Long        ' Error Info.
Public CommStatus As COMSTAT    ' Port Status

Public Const GENERIC_READ = &H80000000
Public Const GENERIC_WRITE = &H40000000
Public Const FILE_FLAG_OVERLAPPED = &H40000000
Public Const OPEN_EXISTING = 3
Public Const MAXDWORD = &HFFFF

Public Const PURGE_RXCLEAR = &H8     '  Kill the typeahead buffer if there.
Public Const PURGE_TXCLEAR = &H4     '  Kill the transmit queue if there.
' Comm Errors in ClearCommError Function
Public Const CE_RXOVER = &H1                '  Receive Queue overflow
Public Const CE_OVERRUN = &H2               '  Receive Overrun Error
Public Const CE_RXPARITY = &H4              '  Receive Parity Error
Public Const CE_FRAME = &H8                 '  Receive Framing error
Public Const CE_BREAK = &H10                '  Break Detected
Public Const CE_TXFULL = &H100              '  TX Queue is full
Public Const CE_PTO = &H200                 '  LPTx Timeout
Public Const CE_IOE = &H400                 '  LPTx I/O Error
Public Const CE_DNS = &H800                 '  LPTx Device not selected
Public Const CE_OOP = &H1000                '  LPTx Out-Of-Paper
Public Const CE_MODE = &H8000               '  Requested mode unsupported


Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, _
    ByVal lpSecurityAttributes As String, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As String) As Long
Declare Function WriteFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Long, ByVal lpOverlapped As String) As Boolean
Declare Function ReadFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long, ByVal lpOverlapped As String) As Boolean
Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Declare Function FlushFileBuffers Lib "kernel32" (ByVal hFile As Long) As Long

Declare Function SetCommState Lib "kernel32" (ByVal hCommDev As Long, lpDCB As DCB) As Long
Declare Function SetCommTimeouts Lib "kernel32" (ByVal hFile As Long, lpCommTimeouts As COMMTIMEOUTS) As Long
Declare Function SetCommBreak Lib "kernel32" (ByVal nCid As Long) As Long
Declare Function SetCommMask Lib "kernel32" (ByVal hFile As Long, ByVal dwEvtMask As Long) As Long
Declare Function SetupComm Lib "kernel32" (ByVal hFile As Long, ByVal dwInQueue As Long, ByVal dwOutQueue As Long) As Long
Declare Function GetCommProperties Lib "kernel32" (ByVal hFile As Long, lpCommProp As COMMPROP) As Long
Declare Function GetCommState Lib "kernel32" (ByVal nCid As Long, lpDCB As DCB) As Long
Declare Function GetCommTimeouts Lib "kernel32" (ByVal hFile As Long, lpCommTimeouts As COMMTIMEOUTS) As Long
Declare Function GetCommMask Lib "kernel32" (ByVal hFile As Long, lpEvtMask As Long) As Long
Declare Function GetCommModemStatus Lib "kernel32" (ByVal hFile As Long, lpModemStat As Long) As Long
Declare Function PurgeComm Lib "kernel32" (ByVal hFile As Long, ByVal dwFlags As Long) As Long
Declare Function BuildCommDCB Lib "kernel32" Alias "BuildCommDCBA" (ByVal lpDef As String, lpDCB As DCB) As Long
Declare Function BuildCommDCBAndTimeouts Lib "kernel32" Alias "BuildCommDCBAndTimeoutsA" (ByVal lpDef As String, lpDCB As DCB, lpCommTimeouts As COMMTIMEOUTS) As Long
Declare Function TransmitCommChar Lib "kernel32" (ByVal nCid As Long, ByVal cChar As Byte) As Long
Declare Function ClearCommBreak Lib "kernel32" (ByVal nCid As Long) As Long
Declare Function ClearCommError Lib "kernel32" (ByVal hFile As Long, lpErrors As Long, lpStat As COMSTAT) As Long
Declare Function EscapeCommFunction Lib "kernel32" (ByVal nCid As Long, ByVal nFunc As Long) As Long
Declare Function WaitCommEvent Lib "kernel32" (ByVal hFile As Long, lpEvtMask As Long, ByVal lpOverlapped As String) As Long
Declare Function CommConfigDialog Lib "kernel32" Alias "CommConfigDialogA" (ByVal lpszName As String, ByVal hWnd As Long, lpCC As COMMCONFIG) As Boolean

Type COMMPROP
        wPacketLength As Integer
        wPacketVersion As Integer
        dwServiceMask As Long
        dwReserved1 As Long
        dwMaxTxQueue As Long
        dwMaxRxQueue As Long
        dwMaxBaud As Long
        dwProvSubType As Long
        dwProvCapabilities As Long
        dwSettableParams As Long
        dwSettableBaud As Long
        wSettableData As Integer
        wSettableStopParity As Integer
        dwCurrentTxQueue As Long
        dwCurrentRxQueue As Long
        dwProvSpec1 As Long
        dwProvSpec2 As Long
        wcProvChar(1) As Integer
End Type

Type DCB
        DCBlength As Long
        BaudRate As Long
        bfModeCTL 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

Type COMMTIMEOUTS
        ReadIntervalTimeout As Long
        ReadTotalTimeoutMultiplier As Long
        ReadTotalTimeoutConstant As Long
        WriteTotalTimeoutMultiplier As Long
        WriteTotalTimeoutConstant As Long
End Type

Type COMSTAT
        bfHold As Long
        cbInQue As Long
        cbOutQue As Long
End Type

Type COMMCONFIG
    dwSize As Long
    wVersion As Integer
    wReserved As Integer
    dcbx As DCB
    dwProviderSubType As Long
    dwProviderOffset As Long
    dwProviderSize As Long
    wcProviderData As Byte
End Type

Public Function CommOpen(Port As String, Baud As Long) As Long
Dim Tmo As COMMTIMEOUTS
Dim CommCB As DCB

    CommAbort = True
    CommOpen = CreateFile(Port, (GENERIC_READ Or GENERIC_WRITE), 0&, vbNullString, OPEN_EXISTING, FILE_FLAG_OVERLAPPED, vbNullString)
    If CommOpen = -1 Then Exit Function
    SetCommMask CommOpen, 0&
    SetupComm CommOpen, 256&, 256&
    Tmo.ReadIntervalTimeout = MAXDWORD
    Tmo.ReadTotalTimeoutMultiplier = 10&
    Tmo.ReadTotalTimeoutConstant = 10000&
    Tmo.WriteTotalTimeoutMultiplier = 10&
    Tmo.WriteTotalTimeoutConstant = 1000&
    SetCommTimeouts CommOpen, Tmo
    GetCommState CommOpen, CommCB
    CommCB.DCBlength = LenB(CommCB)
    CommCB.BaudRate = Baud
    CommCB.bfModeCTL = (CommCB.bfModeCTL And &HFFFF) Or &H20D5
    CommCB.ByteSize = 8
    CommCB.Parity = 0
    CommCB.StopBits = 0
    If SetCommState(CommOpen, CommCB) = 0 Then GoTo CommOpenErr
    CommAbort = False
    Exit Function
CommOpenErr:
    CloseHandle (CommOpen)
    CommOpen = -2
End Function

Public Function CommInQue(hComm As Long) As Long
    If ClearCommError(hComm, CommError, CommStatus) Then
        CommInQue = CommStatus.cbInQue
    Else
        CommInQue = -1
    End If

End Function

Public Sub CommSendLine(hComm As Long, Mes As String)
Dim I As Long
Dim N As Long
Dim Txt As String

    Select Case CommLineDelimLen
    Case 1: Txt = Mes & Chr(CommLineDelim(0))
    Case 2: Txt = Mes & Chr(CommLineDelim(0)) & Chr(CommLineDelim(1))
    Case Else: Txt = Mes
    End Select
    I = Len(Txt)
    WriteFile hComm, ByVal Txt, I, N, vbNullString
    If N < I Then
        ClearCommError hComm, CommError, CommStatus
        CommAbort = True
    Else
        CommAbort = False
    End If
    CommCount = N
End Sub

Public Sub CommSendData(hComm As Long, Mes As String)
Dim I As Long
Dim N As Long

    I = Len(Mes)
    WriteFile hComm, ByVal Txt, I, N, vbNullString
    If N < I Then
        ClearCommError hComm, CommError, CommStatus
        CommAbort = True
    Else
        CommAbort = False
    End If
    CommCount = N
End Sub

Public Function CommGetC(hComm As Long) As Long
Dim N As Long
Dim C As Byte

    ReadFile hComm, C, 1&, N, vbNullString
    If N = 0 Then
        ClearCommError hComm, CommError, CommStatus
        CommGetC = -1
        CommAbort = True
    Else
        CommLastByte = C
        CommGetC = CLng(C)
        CommAbort = False
    End If
End Function

Public Function CommRecvLine(hComm As Long, L As Long) As String
Dim N As Long
Dim I As Long
Dim C As Byte

    I = 0
    CommRecvLine = ""
    Do
        ReadFile hComm, C, 1&, N, vbNullString
        If N = 0 Then Exit Do
        I = I + 1
        If CommLineDelimLen = 1 Then
            CommLastByte = C
            If C = CommLineDelim(0) Then Exit Do    ' C = LF Case
            CommRecvLine = CommRecvLine & Chr(C)
        ElseIf CommLastByte = CommLineDelim(0) Then
            If C = CommLineDelim(1) Then
                CommLastByte = C
                Exit Do                             ' LB=CR, C=LF Case
            Else
                CommRecvLine = CommRecvLine & Chr(CommLastByte) & Chr(C)
                CommLastByte = C                    ' LB=CR, C<>LF Case
            End If
        ElseIf C = CommLineDelim(0) Then
            CommLastByte = C                        ' LB<>CR, C=CR Case
        Else
            CommRecvLine = CommRecvLine & Chr(C)
            CommLastByte = C                        ' LB<>CR, C<>CR Case
        End If
    Loop While I < L
    If N = 0 Then
        ClearCommError hComm, CommError, CommStatus
        CommAbort = True
    Else
        CommAbort = False
    End If
    CommCount = I
End Function

Public Function CommRecvData(hComm As Long, L As Long) As String
Dim N As Long
Dim I As Long
Dim C As Byte

    I = 0
    CommRecvData = ""
    Do
        ReadFile hComm, C, 1&, N, vbNullString
        If N = 0 Then Exit Do
        I = I + 1
        If (CommDataDelim(0) <> 0 And C = CommDataDelim(0)) Or _
           (CommDataDelim(1) <> 0 And C = CommDataDelim(1)) Then
            CommLastByte = C
            Exit Do
        ElseIf CommLineDelimLen = 1 Then
            CommLastByte = C
            If C = CommLineDelim(0) Then Exit Do    ' C = LF Case
            CommRecvData = CommRecvData & Chr(C)
        ElseIf CommLastByte = CommLineDelim(0) Then
            If C = CommLineDelim(1) Then
                CommLastByte = C
                Exit Do                             ' LB=CR, C=LF Case
            Else
                CommRecvData = CommRecvData & Chr(CommLastByte) & Chr(C)
                CommLastByte = C                    ' LB=CR, C<>LF Case
            End If
        ElseIf C = CommLineDelim(0) Then
            CommLastByte = C                        ' LB<>CR, C=CR Case
        Else
            CommRecvData = CommRecvData & Chr(C)
            CommLastByte = C                        ' LB<>CR, C<>CR Case
        End If
    Loop While I < L
    If N = 0 Then
        ClearCommError hComm, CommError, CommStatus
        CommAbort = True
    Else
        CommAbort = False
    End If
    CommCount = I
End Function

Public Sub CommClose(hComm As Long)
    CloseHandle hComm
End Sub

Public Function CommSendBin(hComm As Long, BArray As Byte, ByVal BALen As Long) As Boolean
Dim N As Long

    CommSendBin = WriteFile(hComm, BArray, BALen, N, vbNullString)
    If N = BALen Then ClearCommError hComm, CommError, CommStatus
    CommCount = N
End Function

Public Function CommRecvBin(hComm As Long, BArray() As Byte, ByVal BALen As Long) As Boolean
Dim N As Long

    CommRecvBin = ReadFile(hComm, BArray(0), BALen, N, vbNullString)
    If N = BALen Then ClearCommError hComm, CommError, CommStatus
    CommCount = N
    If N > 0 Then CommLastByte = BArray(N - 1)
End Function