VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "dwComm"
Attribute VB_Creatable = True
Attribute VB_Exposed = False
' dwDCB - Device Communication Block utility class
' Part of the Desaware API Class Library
' Copyright (c) 1996 by Desaware.
' All Rights Reserved
Option Explicit

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

Private Type OVERLAPPED
        Internal As Long
        InternalHigh As Long
        offset As Long
        OffsetHigh As Long
        hEvent As Long
End Type

' Private members
Private timeouts As COMMTIMEOUTS
Private handle As Long  ' Comm handle
Private devname$ ' Com1, com2 or other compatible comm device

' Public members
Public DCB As dwDCB

' Current state indicators
' Holds output data that arrives while an output transfer is in progress
Private PendingOutput$
Private CurrentEventMask&   ' Non zero if events are being watched for
' Buffers for overlapped input and output
' Must take this approach due to VB's ability to move strings
Private CurrentInputBuffer&
Private CurrentOutputBuffer&
Private TriggeredEvents&    ' Variable to load with event results

' Three overlapped structures,
' 0 = read, 1 = write, 2 = waitevent
Private overlaps(2) As OVERLAPPED
' Indicates background operation is in progress
Private inprogress(2) As Boolean
' Amount of data transferred on write
Private DataWritten&
Private DataRead&
Private EventResults&

' This object must have two functions
' CommInput(dev As dwComm, info As String)
' CommEvent(dev As dwComm, event as long)
Private CallbackObject As Object

' Declarations
Private Declare Function apiSetCommTimeouts Lib "kernel32" Alias "SetCommTimeouts" (ByVal hFile As Long, lpCommTimeouts As COMMTIMEOUTS) As Long
Private Declare Function apiGetCommTimeouts Lib "kernel32" Alias "GetCommTimeouts" (ByVal hFile As Long, lpCommTimeouts As COMMTIMEOUTS) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) 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 SetupComm Lib "kernel32" (ByVal hFile As Long, ByVal dwInQueue As Long, ByVal dwOutQueue As Long) As Long
Private Declare Function GetCommModemStatus Lib "kernel32" (ByVal hFile As Long, lpModemStat As Long) As Long
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function lstrcpyFromBuffer Lib "kernel32" Alias "lstrcpynA" (ByVal lpString1 As String, ByVal buffer As Long, ByVal iMaxLength As Long) As Long
Private Declare Function lstrcpyToBuffer Lib "kernel32" Alias "lstrcpynA" (ByVal buffer As Long, ByVal lpString2 As String, ByVal iMaxLength As Long) As Long
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As String) As Long
Private Declare Function GetLastError Lib "kernel32" () As Long
Private Declare Function CreateEvent Lib "kernel32" Alias "CreateEventA" (ByVal lpEventAttributes As Long, ByVal bManualReset As Long, ByVal bInitialState As Long, ByVal lpName As String) As Long
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function WriteFile Lib "kernel32" (ByVal hFile As Long, ByVal lpBuffer As Long, ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Long, lpOverlapped As OVERLAPPED) As Long
Private Declare Function ReadFile Lib "kernel32" (ByVal hFile As Long, ByVal lpBuffer As Long, ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long, lpOverlapped As OVERLAPPED) As Long
Private Declare Function SetCommMask Lib "kernel32" (ByVal hFile As Long, ByVal dwEvtMask As Long) As Long
Private Declare Function ClearCommError Lib "kernel32" (ByVal hFile As Long, lpErrors As Long, ByVal l As Long) As Long
Private Declare Function WaitCommEvent Lib "kernel32" (ByVal hFile As Long, lpEvtMask As Long, lpOverlapped As OVERLAPPED) As Long

Private Const GENERIC_READ = &H80000000
Private Const GENERIC_WRITE = &H40000000
Private Const OPEN_EXISTING = 3
Private Const FILE_FLAG_OVERLAPPED = &H40000000
Private Const INVALID_HANDLE_VALUE = -1
Private Const GMEM_FIXED = &H0
Private Const ClassBufferSizes% = 1024
Private Const ERROR_IO_PENDING = 997 '  dderror
Private Const WAIT_TIMEOUT = &H102&

' GetCommModemStatus flags
Private Const MS_CTS_ON = &H10&
Private Const MS_DSR_ON = &H20&
Private Const MS_RING_ON = &H40&
Private Const MS_RLSD_ON = &H80&

' Error values
Private Const CLASS_NAME$ = "dwComm"
Private Const ERR_NOCOMMACCESS = 31010
Private Const ERR_UNINITIALIZED = 31011
Private Const ERR_MODEMSTATUS = 31012
Private Const ERR_READFAIL = 31013
Private Const ERR_EVENTFAIL = 31014

Private Const EV_RXCHAR = &H1                '  Any Character received
Private Const EV_RXFLAG = &H2                '  Received certain character
Private Const EV_TXEMPTY = &H4               '  Transmitt Queue Empty
Private Const EV_CTS = &H8                   '  CTS changed state
Private Const EV_DSR = &H10                  '  DSR changed state
Private Const EV_RLSD = &H20                 '  RLSD changed state
Private Const EV_BREAK = &H40                '  BREAK received
Private Const EV_ERR = &H80                  '  Line status error occurred
Private Const EV_RING = &H100                '  Ring signal detected
Private Const EV_PERR = &H200                '  Printer error occured
Private Const EV_RX80FULL = &H400            '  Receive buffer is 80 percent full
Private Const EV_EVENT1 = &H800              '  Provider specific event 1
Private Const EV_EVENT2 = &H1000             '  Provider specific event 2

Private Const CE_RXOVER = &H1                '  Receive Queue overflow
Private Const CE_OVERRUN = &H2               '  Receive Overrun Error
Private Const CE_RXPARITY = &H4              '  Receive Parity Error
Private Const CE_FRAME = &H8                 '  Receive Framing error
Private Const CE_BREAK = &H10                '  Break Detected
Private Const CE_TXFULL = &H100              '  TX Queue is full

' An empty string with a single null character
Private EmptyString As String * 1

Private Sub Class_Initialize()
    Dim olnum%
    Set DCB = New dwDCB
    CurrentInputBuffer = GlobalAlloc(GMEM_FIXED, ClassBufferSizes + 1)
    CurrentOutputBuffer = GlobalAlloc(GMEM_FIXED, ClassBufferSizes + 1)
    CurrentEventMask = EV_ERR
    EmptyString = Chr$(0)
    ' Create event objects for the background transfer
    For olnum = 0 To 2
        overlaps(olnum).hEvent = CreateEvent(0, True, False, vbNullString)
    Next olnum
End Sub

Private Sub Class_Terminate()
    Dim olnum
    ' Close existing comm device
    Call CloseComm
    ' Dump the event objects
    For olnum = 0 To 2
        Call CloseHandle(overlaps(olnum).hEvent)
    Next olnum
    Set DCB = Nothing   ' Be sure DCB is free
    Call GlobalFree(CurrentInputBuffer)
    Call GlobalFree(CurrentOutputBuffer)
    
End Sub

' Useful error routines
Private Sub DeviceNotOpenedError()
    Err.Raise vbObjectError + ERR_UNINITIALIZED, CLASS_NAME, "Communication Device is not open"
End Sub

Private Sub ModemStatusError()
    Err.Raise vbObjectError + ERR_MODEMSTATUS, CLASS_NAME, "GetCommModemStatus Failed"
End Sub


'-----------------------------------------------
' Timeout property access follows
'-----------------------------------------------
Public Property Get ReadIntervalTimeout() As Long
    ReadIntervalTimeout = timeouts.ReadIntervalTimeout
End Property

Public Property Let ReadIntervalTimeout(vNewValue As Long)
    timeouts.ReadIntervalTimeout = vNewValue
End Property

Public Property Get ReadTotalTimeoutMultiplier() As Long
    ReadTotalTimeoutMultiplier = timeouts.ReadTotalTimeoutMultiplier
End Property

Public Property Let ReadTotalTimeoutMultiplier(vNewValue As Long)
    timeouts.ReadTotalTimeoutMultiplier = vNewValue
End Property


Public Property Get ReadTotalTimeoutConstant() As Long
    ReadTotalTimeoutConstant = timeouts.ReadTotalTimeoutConstant
End Property

Public Property Let ReadTotalTimeoutConstant(vNewValue As Long)
    timeouts.ReadTotalTimeoutConstant = ReadTotalTimeoutConstant
End Property

Public Property Get WriteTotalTimeoutMultiplier() As Long
    WriteTotalTimeoutMultiplier = timeouts.WriteTotalTimeoutMultiplier
End Property

Public Property Let WriteTotalTimeoutMultiplier(vNewValue As Long)
    timeouts.WriteTotalTimeoutMultiplier = WriteTotalTimeoutMultiplier
End Property

Public Property Get WriteTotalTimeoutConstant() As Long
    WriteTotalTimeoutConstant = timeouts.WriteTotalTimeoutConstant
End Property

Public Property Let WriteTotalTimeoutConstant(vNewValue As Long)
    timeouts.WriteTotalTimeoutConstant = WriteTotalTimeoutConstant
End Property

' The device handle is read only
Public Property Get hCommDev() As Long
    hCommDev = handle
End Property

' This property is read only
Public Property Get DeviceName() As String
    DeviceName = devname
End Property

Public Sub GetCommTimeouts()
    ' Is there any real need to report errors here?
    If handle = 0 Then Exit Sub
    Call apiGetCommTimeouts(handle, timeouts)
End Sub

Public Function SetCommTimeouts() As Long
    If handle = 0 Then Exit Function ' Returns false
    SetCommTimeouts = apiSetCommTimeouts(handle, timeouts) <> 0
End Function

' The main function for opening a comm device
' Receives device name (com?) and optionally the size of the internal input and output queues
Public Function OpenComm(CommDeviceName As String, Notify As Object, Optional cbInQueue, Optional cbOutQueue) As Long
    ' Close an existing port when reopening
    If handle <> 0 Then CloseComm
    devname = CommDeviceName
    Set CallbackObject = Notify
    handle = CreateFile(devname, GENERIC_READ Or GENERIC_WRITE, 0, 0, OPEN_EXISTING, FILE_FLAG_OVERLAPPED, 0)
    If handle = INVALID_HANDLE_VALUE Then Err.Raise vbObjectError + ERR_NOCOMMACCESS, CLASS_NAME, "Unable to open communications device"
    ' If the input and output queue size is specified, set it now
    If Not (IsMissing(cbInQueue) Or IsMissing(cbOutQueue)) Then
        Call SetupComm(handle, cbInQueue, cbOutQueue)
    Else
        Call SetupComm(handle, 8192, 1024)
    End If
    ' Ok, we've got the comm port. Initialize the timeouts
    GetCommTimeouts
    ' Set some default timeouts
    timeouts.ReadIntervalTimeout = 1
    timeouts.ReadTotalTimeoutMultiplier = 0
    timeouts.ReadTotalTimeoutConstant = 10
    timeouts.WriteTotalTimeoutMultiplier = 1
    timeouts.WriteTotalTimeoutConstant = 1
    SetCommTimeouts
    ' Initialize the DCB to the current device parameters
    Call DCB.GetCommState(Me)
    Call SetCommMask(handle, CurrentEventMask)
    StartInput
End Function