Programmer 7500/MAX_PROGRAMMERS.iso/VISUAL_B/CODIGO_2/VB_TERM2/SERIAL.BAS

BASIC Source File | 1991-08-20 | 7.5 KB | 202 lines

'----------------------------------------------------------------------------
'    Serial Communications Module for VB
'----------------------------------------------------------------------------
'
'  COMM declarations
'
'----------------------------------------------------------------------------
Const NOPARITY = 0
Const ODDPARITY = 1
Const EVENPARITY = 2
Const MARKPARITY = 3
Const SPACEPARITY = 4

Const ONESTOPBIT = 0
Const ONE5STOPBITS = 1
Const TWOSTOPBITS = 2

Const IGNORE = 0 '  Ignore signal
Const INFINITE = &HFFFF  '  Infinite timeout

'----------------------------------------------------------------------------
'  Error Flags
'----------------------------------------------------------------------------
Const CE_RXOVER = &H1    '  Receive Queue overflow
Const CE_OVERRUN = &H2   '  Receive Overrun Error
Const CE_RXPARITY = &H4  '  Receive Parity Error
Const CE_FRAME = &H8     '  Receive Framing error
Const CE_BREAK = &H10    '  Break Detected
Const CE_CTSTO = &H20    '  CTS Timeout
Const CE_DSRTO = &H40    '  DSR Timeout
Const CE_RLSDTO = &H80   '  RLSD Timeout
Const CE_TXFULL = &H100  '  TX Queue is full
Const CE_PTO = &H200     '  LPTx Timeout
Const CE_IOE = &H400     '  LPTx I/O Error
Const CE_DNS = &H800     '  LPTx Device not selected
Const CE_OOP = &H1000    '  LPTx Out-Of-Paper
Const CE_MODE = &H8000   '  Requested mode unsupported

Const IE_BADID = (-1)    '  Invalid or unsupported id
Const IE_OPEN = (-2)     '  Device Already Open
Const IE_NOPEN = (-3)    '  Device Not Open
Const IE_MEMORY = (-4)   '  Unable to allocate queues
Const IE_DEFAULT = (-5)  '  Error in default parameters
Const IE_HARDWARE = (-10)        '  Hardware Not Present
Const IE_BYTESIZE = (-11)        '  Illegal Byte Size
Const IE_BAUDRATE = (-12)        '  Unsupported BaudRate

'----------------------------------------------------------------------------
'  Events
'----------------------------------------------------------------------------
Const EV_RXCHAR = &H1    '  Any Character received
Const EV_RXFLAG = &H2    '  Received certain character
Const EV_TXEMPTY = &H4   '  Transmitt Queue Empty
Const EV_CTS = &H8       '  CTS changed state
Const EV_DSR = &H10      '  DSR changed state
Const EV_RLSD = &H20     '  RLSD changed state
Const EV_BREAK = &H40    '  BREAK received
Const EV_ERR = &H80      '  Line status error occurred
Const EV_RING = &H100    '  Ring signal detected
Const EV_PERR = &H200    '  Printer error occured

'----------------------------------------------------------------------------
'  Escape Functions
'----------------------------------------------------------------------------
Const SETXOFF = 1        '  Simulate XOFF received
Const SETXON = 2 '  Simulate XON received
Const SETRTS = 3 '  Set RTS high
Const CLRRTS = 4 '  Set RTS low
Const SETDTR = 5 '  Set DTR high
Const CLRDTR = 6 '  Set DTR low
Const RESETDEV = 7       '  Reset device if possible

Const LPTx = &H80        '  Set if ID is for LPT device


'----------------------------------------------------------------------------
'   Function Definitions
'----------------------------------------------------------------------------
Declare Function OpenComm Lib "User" (ByVal lpComName As String, ByVal wInQueue As Integer, ByVal wOutQueue As Integer) As Integer
Declare Function SetCommState Lib "User" (lpdcb As DCB) As Integer
Declare Function GetCommState Lib "User" (ByVal nCid As Integer, lpdcb As DCB) As Integer
Declare Function ReadComm Lib "User" (ByVal nCid As Integer, ByVal lpBuf As String, ByVal nSize As Integer) As Integer
Declare Function UngetCommChar Lib "User" (ByVal nCid As Integer, ByVal cChar As Integer) As Integer
Declare Function WriteComm Lib "User" (ByVal nCid As Integer, ByVal lpBuf As String, ByVal nSize As Integer) As Integer
Declare Function CloseComm Lib "User" (ByVal nCid As Integer) As Integer
Declare Function BuildCommDCB Lib "User" (ByVal lpDef As String, lpdcb As DCB) As Integer
Declare Function TransmitCommChar Lib "User" (ByVal nCid As Integer, ByVal cChar As Integer) As Integer
Declare Function SetCommEventMask Lib "User" (ByVal nCid As Integer, nEvtMask As Integer) As Long
Declare Function GetCommEventMask Lib "User" (ByVal nCid As Integer, ByVal nEvtMask As Integer) As Integer
Declare Function SetCommBreak Lib "User" (ByVal nCid As Integer) As Integer
Declare Function ClearCommBreak Lib "User" (ByVal nCid As Integer) As Integer
Declare Function FlushComm Lib "User" (ByVal nCid As Integer, ByVal nQueue As Integer) As Integer
Declare Function EscapeCommFunction Lib "User" (ByVal nCid As Integer, ByVal nFunc As Integer) As Integer
Declare Function GetCommError Lib "User" (ByVal nCid As Integer, lpStat As COMSTAT) As Integer

'----------------------------------------------------------------------------
'   Bits  for bits1 and bits2
'----------------------------------------------------------------------------
'   Bits1
'----------------------------------------------------------------------------
Const fbinary = &H1
Const frtsdiable = &H2
Const fparity = &H4
Const foutxctsflow = &H8
Const foutxdsrflow = &H10
Const fdtrdisable = &H80

'----------------------------------------------------------------------------
'   Bits2
'----------------------------------------------------------------------------
Const foutx = &H1
Const finx = &H2
Const fpechar = &H4
Const fnull = &H8
Const fchevt = &H10
Const fdtrflow = &H20
Const frtsflow = &H40

'----------------------------------------------------------------------------
'   Definitions of our open port
'----------------------------------------------------------------------------
Dim nCid     As Integer
Dim PortName    As String

Function SerialOpen (ComPort As Integer) As Integer
'
'    Open the serial port. Expects the com port number as the argument
'    and returns either zero for success, or non-zero on error
'
    PortName = "COM" + Format$(ComPort, "#")
    nCid = OpenComm(PortName, 2048, 128)
    If (nCid < 0) Then
        SerialOpen = nCid
    Else
        SerialOpen = 0
    End If
End Function

Function SerialClose () As Integer
'
'    Closes the serial port.  Zero return on OK
'
    x% = CloseComm(nCid)
    If (x% < 0) Then
        SerialClose = x%
    Else
        SerialClose = 0
    End If
End Function

Function SerialConfig (baud%, bits%, Parity$) As Integer
'
'    Configure the open serial port
'
    Dim lpdcb As DCB
    Dim ConfigString As String

    ConfigString = PortName + ":"
    ConfigString = ConfigString + Format$(baud%) + ","
    ConfigString = ConfigString + Left$(UCase$(Parity$), 1) + ","
    ConfigString = ConfigString + Format$(bits%, "#") + ",1"
    i% = BuildCommDCB(ConfigString, lpdcb)

    lpdcb.id = Chr$(nCid)
    lpdcb.bits2 = Chr$(Asc(lpdcb.bits2) Or finx)
    lpdcb.XonChar = Chr$(Asc("Q") - 64)
    lpdcb.XoffChar = Chr$(Asc("S") - 64)
    lpdcb.XonLim = 256
    lpdcb.XoffLim = 256

    SerialConfig = SetCommState(lpdcb)

End Function

Function SerialWrite (t$) As Integer

    Dim st As COMSTAT

    status% = GetCommError(nCid, st)
    status% = WriteComm(nCid, t$, Len(t$))
    If status% < 0 Then status% = GetCommError(nCid, st)
    SerialWrite = status%

End Function

Function SerialRead (buf$, ByVal max%) As Integer

    Dim st As COMSTAT

    buf$ = Space$(max%)
    i% = ReadComm(nCid, buf$, max%)

    If (i% > 0) Then
        SerialRead = i%
    Else
        SerialRead = Abs(i%)
        i% = GetCommError(nCid, st)
    End If

End Function