2002-02-06 22:07

     Attribute VB_Name = "modCOMM"
     OPTION EXPLICIT

'-------------------------------------------------------------------------------
' modCOMM - Written by: David M. Hitchner
'
' This VB module is a collection of routines to perform serial port I/O without
' using the Microsoft Comm Control component.  This module uses the Windows API
' to perform the overlapped I/O operations necessary for serial communications.
'
' The routine can handle up to 4 serial ports which are identified with a
' Port ID.
'
' All routines (with the exception of CommRead and CommWrite) return an error
' code or 0 if no error occurs.  The routine CommGetError can be used to get
' the complete error message.
'-------------------------------------------------------------------------------

'-------------------------------------------------------------------------------
' Public Constants
'-------------------------------------------------------------------------------

' Output Control Lines (CommSetLine)
     Public CONST LINE_BREAK = 1
     Public CONST LINE_DTR = 2
     Public CONST LINE_RTS = 3

' Input Control Lines  (CommGetLine)
     Public CONST LINE_CTS = &H10&
     Public CONST LINE_DSR = &H20&
     Public CONST LINE_RING = &H40&
     Public CONST LINE_RLSD = &H80&
     Public CONST LINE_CD = &H80&

'-------------------------------------------------------------------------------
' System Constants
'-------------------------------------------------------------------------------
     Private CONST ERROR_IO_INCOMPLETE = 996&
     Private CONST ERROR_IO_PENDING = 997
     Private CONST GENERIC_READ = &H80000000
     Private CONST GENERIC_WRITE = &H40000000
     Private CONST FILE_ATTRIBUTE_NORMAL = &H80
     Private CONST FILE_FLAG_OVERLAPPED = &H40000000
     Private CONST FORMAT_MESSAGE_FROM_SYSTEM = &H1000
     Private CONST OPEN_EXISTING = 3

' COMM Functions
     Private CONST MS_CTS_ON = &H10&
     Private CONST MS_DSR_ON = &H20&
     Private CONST MS_RING_ON = &H40&
     Private CONST MS_RLSD_ON = &H80&
     Private CONST PURGE_RXABORT = &H2
     Private CONST PURGE_RXCLEAR = &H8
     Private CONST PURGE_TXABORT = &H1
     Private CONST PURGE_TXCLEAR = &H4

' COMM Escape Functions
     Private CONST CLRBREAK = 9
     Private CONST CLRDTR = 6
     Private CONST CLRRTS = 4
     Private CONST SETBREAK = 8
     Private CONST SETDTR = 5
     Private CONST SETRTS = 3

'-------------------------------------------------------------------------------
' System Structures
'-------------------------------------------------------------------------------
     Private TYPE COMSTAT
     fBitFields AS LONG ' See Comment in Win32API.Txt
     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

'
' The DCB structure defines the control setting for a serial
' communications device.
'
     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 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

'-------------------------------------------------------------------------------
' System Functions
'-------------------------------------------------------------------------------
'
' Fills a specified DCB structure with values specified in
' a device-control string.
'
     DECLARE FUNCTION BuildCommDCB LIB "kernel32" ALIAS "BuildCommDCBA" _
      (BYVAL lpDef AS STRING, lpDCB AS DCB) AS LONG
'
' Retrieves information about a communications error and reports
' the current status of a communications device. The function is
' called when a communications error occurs, and it clears the
' device's error flag to enable additional input and output
' (I/O) operations.
'
     DECLARE FUNCTION ClearCommError LIB "kernel32" _
      (BYVAL hFile AS LONG, lpErrors AS LONG, lpStat AS COMSTAT) AS LONG
'
' Closes an open communications device or file handle.
'
     DECLARE FUNCTION CloseHandle LIB "kernel32" (BYVAL hObject AS LONG) AS LONG
'
' Creates or opens a communications resource and returns a handle
' that can be used to access the resource.
'
     DECLARE FUNCTION CreateFile LIB "kernel32" ALIAS "CreateFileA" _
      (BYVAL lpFileName AS STRING, BYVAL dwDesiredAccess AS LONG, _
      BYVAL dwShareMode AS LONG, lpSecurityAttributes AS ANY, _
      BYVAL dwCreationDisposition AS LONG, BYVAL dwFlagsAndAttributes AS LONG, _
      BYVAL hTemplateFile AS LONG) AS LONG
'
' Directs a specified communications device to perform a function.
'
     DECLARE FUNCTION EscapeCommFunction LIB "kernel32" _
      (BYVAL nCid AS LONG, BYVAL nFunc AS LONG) AS LONG
'
' Formats a message string such as an error string returned
' by anoher function.
'
     DECLARE FUNCTION FormatMessage LIB "kernel32" ALIAS "FormatMessageA" _
      (BYVAL dwFlags AS LONG, lpSource AS ANY, BYVAL dwMessageId AS LONG, _
      BYVAL dwLanguageId AS LONG, BYVAL lpBuffer AS STRING, BYVAL nSize AS LONG, _
      Arguments AS LONG) AS LONG
'
' Retrieves modem control-register values.
'
     DECLARE FUNCTION GetCommModemStatus LIB "kernel32" _
      (BYVAL hFile AS LONG, lpModemStat AS LONG) AS LONG
'
' Retrieves the current control settings for a specified
' communications device.
'
     DECLARE FUNCTION GetCommState LIB "kernel32" _
      (BYVAL nCid AS LONG, lpDCB AS DCB) AS LONG
'
' Retrieves the calling thread's last-error code value.
'
     DECLARE FUNCTION GetLastError LIB "kernel32" () AS LONG
'
' Retrieves the results of an overlapped operation on the
' specified file, named pipe, or communications device.
'
     DECLARE FUNCTION GetOverlappedResult LIB "kernel32" _
      (BYVAL hFile AS LONG, lpOverlapped AS OVERLAPPED, _
      lpNumberOfBytesTransferred AS LONG, BYVAL bWait AS LONG) AS LONG
'
' Discards all characters from the output or input buffer of a
' specified communications resource. It can also terminate
' pending read or write operations on the resource.
'
     DECLARE FUNCTION PurgeComm LIB "kernel32" _
      (BYVAL hFile AS LONG, BYVAL dwFlags AS LONG) AS LONG
'
' Reads data from a file, starting at the position indicated by the
' file pointer. After the read operation has been completed, the
' file pointer is adjusted by the number of bytes actually read,
' unless the file handle is created with the overlapped attribute.
' If the file handle is created for overlapped input and output
' (I/O), the application must adjust the position of the file pointer
' after the read operation.
'
     DECLARE FUNCTION ReadFile LIB "kernel32" _
      (BYVAL hFile AS LONG, BYVAL lpBuffer AS STRING, _
      BYVAL nNumberOfBytesToRead AS LONG, ByRef lpNumberOfBytesRead AS LONG, _
      lpOverlapped AS OVERLAPPED) AS LONG
'
' Configures a communications device according to the specifications
' in a device-control block (a DCB structure). The function
' reinitializes all hardware and control settings, but it does not
' empty output or input queues.
'
     DECLARE FUNCTION SetCommState LIB "kernel32" _
      (BYVAL hCommDev AS LONG, lpDCB AS DCB) AS LONG
'
' Sets the time-out parameters for all read and write operations on a
' specified communications device.
'
     DECLARE FUNCTION SetCommTimeouts LIB "kernel32" _
      (BYVAL hFile AS LONG, lpCommTimeouts AS COMMTIMEOUTS) AS LONG
'
' Initializes the communications parameters for a specified
' communications device.
'
     DECLARE FUNCTION SetupComm LIB "kernel32" _
      (BYVAL hFile AS LONG, BYVAL dwInQueue AS LONG, BYVAL dwOutQueue AS LONG) AS LONG
'
' Writes data to a file and is designed for both synchronous and a
' synchronous operation. The function starts writing data to the file
' at the position indicated by the file pointer. After the write
' operation has been completed, the file pointer is adjusted by the
' number of bytes actually written, except when the file is opened with
' FILE_FLAG_OVERLAPPED. If the file handle was created for overlapped
' input and output (I/O), the application must adjust the position of
' the file pointer after the write operation is finished.
'
     DECLARE FUNCTION WriteFile LIB "kernel32" _
      (BYVAL hFile AS LONG, BYVAL lpBuffer AS STRING, _
      BYVAL nNumberOfBytesToWrite AS LONG, lpNumberOfBytesWritten AS LONG, _
      lpOverlapped AS OVERLAPPED) AS LONG

'-------------------------------------------------------------------------------
' Program Constants
'-------------------------------------------------------------------------------

     Private CONST MAX_PORTS = 4

'-------------------------------------------------------------------------------
' Program Structures
'-------------------------------------------------------------------------------

     Private TYPE COMM_ERROR
     lngErrorCode AS LONG
     strFunction AS STRING
     strErrorMessage AS STRING
     END TYPE

     Private TYPE COMM_PORT
     lngHandle AS LONG
     blnPortOpen AS Boolean
     udtDCB AS DCB
     END TYPE

'-------------------------------------------------------------------------------
' Program Storage
'-------------------------------------------------------------------------------

     Private udtCommOverlap AS OVERLAPPED
     Private udtCommError AS COMM_ERROR
     Private udtPorts(1 TO MAX_PORTS) AS COMM_PORT
'-------------------------------------------------------------------------------
' GetSystemMessage - Gets system error text for the specified error code.
'-------------------------------------------------------------------------------
     Public FUNCTION GetSystemMessage(lngErrorCode AS LONG) AS STRING
     DIM intPos AS INTEGER
     DIM strMessage AS STRING, strMsgBuff AS STRING * 256

     CALL FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, 0, lngErrorCode, 0, strMsgBuff, 255, 0)

     intPos = INSTR(1, strMsgBuff, vbNullChar)
     IF intPos > 0 THEN
      strMessage = Trim$(LEFT$(strMsgBuff, intPos - 1))
     ELSE
      strMessage = Trim$(strMsgBuff)
     END IF

     GetSystemMessage = strMessage

     END FUNCTION


'-------------------------------------------------------------------------------
' CommOpen - Opens/Initializes serial port.
'
'
' Parameters:
'   intPortID   - Port ID used when port was opened.
'   strPort     - COM port name. (COM1, COM2, COM3, COM4)
'   strSettings - Communication settings.
'                 Example: "baud=9600 parity=N data=8 stop=1"
'
' Returns:
'   Error Code  - 0 = No Error.
'
'-------------------------------------------------------------------------------
     Public FUNCTION CommOpen(intPortID AS INTEGER, strPort AS STRING, _
      strSettings AS STRING) AS LONG

     DIM lngStatus       AS LONG
     DIM udtCommTimeOuts AS COMMTIMEOUTS

     ON ERROR GOTO Routine_Error

    ' See if port already in use.
     IF udtPorts(intPortID).blnPortOpen THEN
      lngStatus = -1
      WITH udtCommError
       .lngErrorCode = lngStatus
       .strFunction = "CommOpen"
       .strErrorMessage = "Port in use."
      END WITH

      GOTO Routine_Exit
     END IF

    ' Open serial port.
     udtPorts(intPortID).lngHandle = CreateFile(strPort, GENERIC_READ OR _
      GENERIC_WRITE, 0, BYVAL 0&, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0)

     IF udtPorts(intPortID).lngHandle = -1 THEN
      lngStatus = SetCommError("CommOpen (CreateFile)")
      GOTO Routine_Exit
     END IF

     udtPorts(intPortID).blnPortOpen = True

    ' Setup device buffers (1K each).
     lngStatus = SetupComm(udtPorts(intPortID).lngHandle, 1024, 1024)

     IF lngStatus = 0 THEN
      lngStatus = SetCommError("CommOpen (SetupComm)")
      GOTO Routine_Exit
     END IF

    ' Purge buffers.
     lngStatus = PurgeComm(udtPorts(intPortID).lngHandle, PURGE_TXABORT OR _
      PURGE_RXABORT OR PURGE_TXCLEAR OR PURGE_RXCLEAR)

     IF lngStatus = 0 THEN
      lngStatus = SetCommError("CommOpen (PurgeComm)")
      GOTO Routine_Exit
     END IF

    ' Set serial port timeouts.
     WITH udtCommTimeOuts
      .ReadIntervalTimeout = -1
      .ReadTotalTimeoutMultiplier = 0
      .ReadTotalTimeoutConstant = 1000
      .WriteTotalTimeoutMultiplier = 0
      .WriteTotalTimeoutMultiplier = 1000
     END WITH

     lngStatus = SetCommTimeouts(udtPorts(intPortID).lngHandle, udtCommTimeOuts)

     IF lngStatus = 0 THEN
      lngStatus = SetCommError("CommOpen (SetCommTimeouts)")
      GOTO Routine_Exit
     END IF

    ' Get the current state (DCB).
     lngStatus = GetCommState(udtPorts(intPortID).lngHandle, _
      udtPorts(intPortID).udtDCB)

     IF lngStatus = 0 THEN
      lngStatus = SetCommError("CommOpen (GetCommState)")
      GOTO Routine_Exit
     END IF

    ' Modify the DCB to reflect the desired settings.
     lngStatus = BuildCommDCB(strSettings, udtPorts(intPortID).udtDCB)

     IF lngStatus = 0 THEN
      lngStatus = SetCommError("CommOpen (BuildCommDCB)")
      GOTO Routine_Exit
     END IF

    ' Set the new state.
     lngStatus = SetCommState(udtPorts(intPortID).lngHandle, _
      udtPorts(intPortID).udtDCB)

     IF lngStatus = 0 THEN
      lngStatus = SetCommError("CommOpen (SetCommState)")
      GOTO Routine_Exit
     END IF

     lngStatus = 0

Routine_Exit:
     CommOpen = lngStatus
     EXIT FUNCTION

Routine_Error:
     lngStatus = Err.Number
     WITH udtCommError
      .lngErrorCode = lngStatus
      .strFunction = "CommOpen"
      .strErrorMessage = Err.Description
     END WITH
     RESUME Routine_Exit
     END FUNCTION


     Private FUNCTION SetCommError(strFunction AS STRING) AS LONG

     WITH udtCommError
      .lngErrorCode = Err.LastDllError
      .strFunction = strFunction
      .strErrorMessage = GetSystemMessage(.lngErrorCode)
      SetCommError = .lngErrorCode
     END WITH

     END FUNCTION

     Private FUNCTION SetCommErrorEx(strFunction AS STRING, lngHnd AS LONG) AS LONG
     DIM lngErrorFlags AS LONG
     DIM udtCommStat AS COMSTAT

     WITH udtCommError
      .lngErrorCode = GetLastError
      .strFunction = strFunction
      .strErrorMessage = GetSystemMessage(.lngErrorCode)

      CALL ClearCommError(lngHnd, lngErrorFlags, udtCommStat)

      .strErrorMessage = .strErrorMessage & "  COMM Error Flags = " & _
       HEX$(lngErrorFlags)

      SetCommErrorEx = .lngErrorCode
     END WITH

     END FUNCTION

'-------------------------------------------------------------------------------
' CommSet - Modifies the serial port settings.
'
' Parameters:
'   intPortID   - Port ID used when port was opened.
'   strSettings - Communication settings.
'                 Example: "baud=9600 parity=N data=8 stop=1"
'
' Returns:
'   Error Code  - 0 = No Error.
'-------------------------------------------------------------------------------
     Public FUNCTION CommSet(intPortID AS INTEGER, strSettings AS STRING) AS LONG

     DIM lngStatus AS LONG

     ON ERROR GOTO Routine_Error

     lngStatus = GetCommState(udtPorts(intPortID).lngHandle, _
      udtPorts(intPortID).udtDCB)

     IF lngStatus = 0 THEN
      lngStatus = SetCommError("CommSet (GetCommState)")
      GOTO Routine_Exit
     END IF

     lngStatus = BuildCommDCB(strSettings, udtPorts(intPortID).udtDCB)

     IF lngStatus = 0 THEN
      lngStatus = SetCommError("CommSet (BuildCommDCB)")
      GOTO Routine_Exit
     END IF

     lngStatus = SetCommState(udtPorts(intPortID).lngHandle, _
      udtPorts(intPortID).udtDCB)

     IF lngStatus = 0 THEN
      lngStatus = SetCommError("CommSet (SetCommState)")
      GOTO Routine_Exit
     END IF

     lngStatus = 0

Routine_Exit:
     CommSet = lngStatus
     EXIT FUNCTION

Routine_Error:
     lngStatus = Err.Number
     WITH udtCommError
      .lngErrorCode = lngStatus
      .strFunction = "CommSet"
      .strErrorMessage = Err.Description
     END WITH
     RESUME Routine_Exit
     END FUNCTION

'-------------------------------------------------------------------------------
' CommClose - Close the serial port.
'
' Parameters:
'   intPortID   - Port ID used when port was opened.
'
' Returns:
'   Error Code  - 0 = No Error.
'-------------------------------------------------------------------------------
     Public FUNCTION CommClose(intPortID AS INTEGER) AS LONG

     DIM lngStatus AS LONG

     ON ERROR GOTO Routine_Error

     IF udtPorts(intPortID).blnPortOpen THEN
      lngStatus = CloseHandle(udtPorts(intPortID).lngHandle)

      IF lngStatus = 0 THEN
       lngStatus = SetCommError("CommClose (CloseHandle)")
       GOTO Routine_Exit
      END IF

      udtPorts(intPortID).blnPortOpen = False
     END IF

     lngStatus = 0

Routine_Exit:
     CommClose = lngStatus
     EXIT FUNCTION

Routine_Error:
     lngStatus = Err.Number
     WITH udtCommError
      .lngErrorCode = lngStatus
      .strFunction = "CommClose"
      .strErrorMessage = Err.Description
     END WITH
     RESUME Routine_Exit
     END FUNCTION

'-------------------------------------------------------------------------------
' CommFlush - Flush the send and receive serial port buffers.
'
' Parameters:
'   intPortID   - Port ID used when port was opened.
'
' Returns:
'   Error Code  - 0 = No Error.
'-------------------------------------------------------------------------------
     Public FUNCTION CommFlush(intPortID AS INTEGER) AS LONG

     DIM lngStatus AS LONG

     ON ERROR GOTO Routine_Error

     lngStatus = PurgeComm(udtPorts(intPortID).lngHandle, PURGE_TXABORT OR _
      PURGE_RXABORT OR PURGE_TXCLEAR OR PURGE_RXCLEAR)

     IF lngStatus = 0 THEN
      lngStatus = SetCommError("CommFlush (PurgeComm)")
      GOTO Routine_Exit
     END IF

     lngStatus = 0

Routine_Exit:
     CommFlush = lngStatus
     EXIT FUNCTION

Routine_Error:
     lngStatus = Err.Number
     WITH udtCommError
      .lngErrorCode = lngStatus
      .strFunction = "CommFlush"
      .strErrorMessage = Err.Description
     END WITH
     RESUME Routine_Exit
     END FUNCTION

'-------------------------------------------------------------------------------
' CommRead - Read serial port input buffer.
'
' Parameters:
'   intPortID   - Port ID used when port was opened.
'   strData     - Data buffer.
'   lngSize     - Maximum number of bytes to be read.
'
' Returns:
'   Error Code  - 0 = No Error.
'-------------------------------------------------------------------------------
     Public FUNCTION CommRead(intPortID AS INTEGER, strData AS STRING, _
      lngSize AS LONG) AS LONG

     DIM lngStatus AS LONG
     DIM lngRdSize AS LONG, lngBytesRead AS LONG
     DIM lngRdStatus AS LONG, strRdBuffer AS STRING * 1024
     DIM lngErrorFlags AS LONG, udtCommStat AS COMSTAT

     ON ERROR GOTO Routine_Error

     strData = ""
     lngBytesRead = 0
     DOEVENTS

    ' Clear any previous errors and get current status.
     lngStatus = ClearCommError(udtPorts(intPortID).lngHandle, lngErrorFlags, _
      udtCommStat)

     IF lngStatus = 0 THEN
      lngBytesRead = -1
      lngStatus = SetCommError("CommRead (ClearCommError)")
      GOTO Routine_Exit
     END IF

     IF udtCommStat.cbInQue > 0 THEN
      IF udtCommStat.cbInQue > lngSize THEN
       lngRdSize = udtCommStat.cbInQue
      ELSE
       lngRdSize = lngSize
      END IF
     ELSE
      lngRdSize = 0
     END IF

     IF lngRdSize THEN
      lngRdStatus = ReadFile(udtPorts(intPortID).lngHandle, strRdBuffer, _
       lngRdSize, lngBytesRead, udtCommOverlap)

      IF lngRdStatus = 0 THEN
       lngStatus = GetLastError
       IF lngStatus = ERROR_IO_PENDING THEN
                ' Wait for read to complete.
                ' This function will timeout according to the
                ' COMMTIMEOUTS.ReadTotalTimeoutConstant variable.
                ' Every time it times out, check for port errors.

                ' Loop until operation is complete.
        WHILE GetOverlappedResult(udtPorts(intPortID).lngHandle, _
          udtCommOverlap, lngBytesRead, True) = 0

         lngStatus = GetLastError

         IF lngStatus <> ERROR_IO_INCOMPLETE THEN
          lngBytesRead = -1
          lngStatus = SetCommErrorEx( _
           "CommRead (GetOverlappedResult)", _
           udtPorts(intPortID).lngHandle)
          GOTO Routine_Exit
         END IF
        WEND
       ELSE
                ' Some other error occurred.
        lngBytesRead = -1
        lngStatus = SetCommErrorEx("CommRead (ReadFile)", _
         udtPorts(intPortID).lngHandle)
        GOTO Routine_Exit

       END IF
      END IF

      strData = LEFT$(strRdBuffer, lngBytesRead)
     END IF

Routine_Exit:
     CommRead = lngBytesRead
     EXIT FUNCTION

Routine_Error:
     lngBytesRead = -1
     lngStatus = Err.Number
     WITH udtCommError
      .lngErrorCode = lngStatus
      .strFunction = "CommRead"
      .strErrorMessage = Err.Description
     END WITH
     RESUME Routine_Exit
     END FUNCTION

'-------------------------------------------------------------------------------
' CommWrite - Output data to the serial port.
'
' Parameters:
'   intPortID   - Port ID used when port was opened.
'   strData     - Data to be transmitted.
'
' Returns:
'   Error Code  - 0 = No Error.
'-------------------------------------------------------------------------------
     Public FUNCTION CommWrite(intPortID AS INTEGER, strData AS STRING) AS LONG

     DIM i AS INTEGER
     DIM lngStatus AS LONG, lngSize AS LONG
     DIM lngWrSize AS LONG, lngWrStatus AS LONG

     ON ERROR GOTO Routine_Error

    ' Get the length of the data.
     lngSize = LEN(strData)

    ' Output the data.
     lngWrStatus = WriteFile(udtPorts(intPortID).lngHandle, strData, lngSize, _
      lngWrSize, udtCommOverlap)

    ' Note that normally the following code will not execute because the driver
    ' caches write operations. Small I/O requests (up to several thousand bytes)
    ' will normally be accepted immediately and WriteFile will return true even
    ' though an overlapped operation was specified.

     DOEVENTS

     IF lngWrStatus = 0 THEN
      lngStatus = GetLastError
      IF lngStatus = 0 THEN
       GOTO Routine_Exit
      ELSEIF lngStatus = ERROR_IO_PENDING THEN
            ' We should wait for the completion of the write operation so we know
            ' if it worked or not.
            '
            ' This is only one way to do this. It might be beneficial to place the
            ' writing operation in a separate thread so that blocking on completion
            ' will not negatively affect the responsiveness of the UI.
            '
            ' If the write takes long enough to complete, this function will timeout
            ' according to the CommTimeOuts.WriteTotalTimeoutConstant variable.
            ' At that time we can check for errors and then wait some more.

            ' Loop until operation is complete.
       WHILE GetOverlappedResult(udtPorts(intPortID).lngHandle, _
         udtCommOverlap, lngWrSize, True) = 0

        lngStatus = GetLastError

        IF lngStatus <> ERROR_IO_INCOMPLETE THEN
         lngStatus = SetCommErrorEx( _
          "CommWrite (GetOverlappedResult)", _
          udtPorts(intPortID).lngHandle)
         GOTO Routine_Exit
        END IF
       WEND
      ELSE
            ' Some other error occurred.
       lngWrSize = -1

       lngStatus = SetCommErrorEx("CommWrite (WriteFile)", _
        udtPorts(intPortID).lngHandle)
       GOTO Routine_Exit

      END IF
     END IF

     FOR i = 1 TO 10
      DOEVENTS
     NEXT

Routine_Exit:
     CommWrite = lngWrSize
     EXIT FUNCTION

Routine_Error:
     lngStatus = Err.Number
     WITH udtCommError
      .lngErrorCode = lngStatus
      .strFunction = "CommWrite"
      .strErrorMessage = Err.Description
     END WITH
     RESUME Routine_Exit
     END FUNCTION

'-------------------------------------------------------------------------------
' CommGetLine - Get the state of selected serial port control lines.
'
' Parameters:
'   intPortID   - Port ID used when port was opened.
'   intLine     - Serial port line. CTS, DSR, RING, RLSD (CD)
'   blnState    - Returns state of line (Cleared or Set).
'
' Returns:
'   Error Code  - 0 = No Error.
'-------------------------------------------------------------------------------
     Public FUNCTION CommGetLine(intPortID AS INTEGER, intLine AS INTEGER, _
      blnState AS Boolean) AS LONG

     DIM lngStatus AS LONG
     DIM lngComStatus AS LONG, lngModemStatus AS LONG

     ON ERROR GOTO Routine_Error

     lngStatus = GetCommModemStatus(udtPorts(intPortID).lngHandle, lngModemStatus)

     IF lngStatus = 0 THEN
      lngStatus = SetCommError("CommReadCD (GetCommModemStatus)")
      GOTO Routine_Exit
     END IF

     IF (lngModemStatus AND intLine) THEN
      blnState = True
     ELSE
      blnState = False
     END IF

     lngStatus = 0

Routine_Exit:
     CommGetLine = lngStatus
     EXIT FUNCTION

Routine_Error:
     lngStatus = Err.Number
     WITH udtCommError
      .lngErrorCode = lngStatus
      .strFunction = "CommReadCD"
      .strErrorMessage = Err.Description
     END WITH
     RESUME Routine_Exit
     END FUNCTION

'-------------------------------------------------------------------------------
' CommSetLine - Set the state of selected serial port control lines.
'
' Parameters:
'   intPortID   - Port ID used when port was opened.
'   intLine     - Serial port line. BREAK, DTR, RTS
'                 Note: BREAK actually sets or clears a "break" condition on
'                 the transmit data line.
'   blnState    - Sets the state of line (Cleared or Set).
'
' Returns:
'   Error Code  - 0 = No Error.
'-------------------------------------------------------------------------------
     Public FUNCTION CommSetLine(intPortID AS INTEGER, intLine AS INTEGER, _
      blnState AS Boolean) AS LONG

     DIM lngStatus AS LONG
     DIM lngNewState AS LONG

     ON ERROR GOTO Routine_Error

     IF intLine = LINE_BREAK THEN
      IF blnState THEN
       lngNewState = SETBREAK
      ELSE
       lngNewState = CLRBREAK
      END IF

     ELSEIF intLine = LINE_DTR THEN
      IF blnState THEN
       lngNewState = SETDTR
      ELSE
       lngNewState = CLRDTR
      END IF

     ELSEIF intLine = LINE_RTS THEN
      IF blnState THEN
       lngNewState = SETRTS
      ELSE
       lngNewState = CLRRTS
      END IF
     END IF

     lngStatus = EscapeCommFunction(udtPorts(intPortID).lngHandle, lngNewState)

     IF lngStatus = 0 THEN
      lngStatus = SetCommError("CommSetLine (EscapeCommFunction)")
      GOTO Routine_Exit
     END IF

     lngStatus = 0

Routine_Exit:
     CommSetLine = lngStatus
     EXIT FUNCTION

Routine_Error:
     lngStatus = Err.Number
     WITH udtCommError
      .lngErrorCode = lngStatus
      .strFunction = "CommSetLine"
      .strErrorMessage = Err.Description
     END WITH
     RESUME Routine_Exit
     END FUNCTION



'-------------------------------------------------------------------------------
' CommGetError - Get the last serial port error message.
'
' Parameters:
'   strMessage  - Error message from last serial port error.
'
' Returns:
'   Error Code  - Last serial port error code.
'-------------------------------------------------------------------------------
     Public FUNCTION CommGetError(strMessage AS STRING) AS LONG

     WITH udtCommError
      CommGetError = .lngErrorCode
      strMessage = "Error (" & CStr(.lngErrorCode) & "): " & .strFunction & _
       " - " & .strErrorMessage
     END WITH

     END FUNCTION

2002-02-06 22:07