Visual Basic 4 Power Pack/Visual_Basic4_Power_Pack.bin/vb4files/ppl4vb20/vb_io.bas

BASIC Source File | 1996-11-20 | 5.4 KB | 243 lines

'
' -- VB_IO.BAS --
'
' The display screen is divided up into three parts. The TOP consists
' of the top 24 rows, numbered 1 to 24. The LEFT consists of the first
' 35 columns of the last row (row 25). The RIGHT consists of the last
' 45 columns of the last row.
'
' All protocol I/O is done to the RIGHT.
'

DEFINT A-Z

'     vbPutChar : Print a character.
'   vbPutString : Print a string.
'      vbPutEOL : Print a EOL character (clears line).
'   vbPutEOLstr : Print a EOL character then prints string.
'  vbPutInteger : Print integer.
'     vbPutLong : Print long integer.
'  vbPutHexByte : Print byte as hexidecimal number.
'  vbPutHexWord : Print word as hexidecimal number.
'
'    vbKeyPress : Returns TRUE if key has been pressed
'      vbGetKey : Get next keyboard character (wait, no echo)
'   vbGetString : Get a string, echoing.
'
'       vbDebug : Echo to the main display (rows 1 - 24)
'

'$INCLUDE: 'CONFIG.BI'
'$INCLUDE: 'MINMAX.BI'
'$INCLUDE: 'VB_IO.BI'

CONST False = 0
CONST True = NOT False

CONST WHITE = 7
CONST BLACK = 0

CONST RightHalf = 36

DIM SHARED DebugFlag AS INTEGER

DIM SHARED vbCol     AS INTEGER    'current column on right half of row 25
DIM SHARED MainRow   AS INTEGER    'current row on main screen
DIM SHARED MainCol   AS INTEGER    'current column on main screen
DIM SHARED Temp      AS STRING     'temporary string
DIM SHARED LastChar  AS STRING     'last keyboard character

SUB vbDebug(BYVAL Flag AS INTEGER)
DebugFlag = Flag
END SUB

' print character

SUB vbPutChar(BYVAL Chr AS INTEGER)
IF DebugFlag THEN
  PRINT CHR$(Chr);
END IF
MainRow = CSRLIN
MainCol = POS(0)
VIEW PRINT 25 TO 25
COLOR BLACK, WHITE
LOCATE 25, RightHalf+vbCol, 1
IF vbCol < RightHalf-1 THEN
  PRINT CHR$(Chr);
  vbCol = POS(0) - RightHalf
END IF
VIEW PRINT 1 TO 24
COLOR WHITE, BLACK
LOCATE MainRow, MainCol, 1
END SUB

'print string

SUB vbPutString(TheString AS STRING)
DIM L AS INTEGER
IF DebugFlag THEN
  PRINT TheString;
END IF
MainRow = CSRLIN
MainCol = POS(0)
VIEW PRINT 25 TO 25
COLOR BLACK, WHITE
LOCATE 25, RightHalf+vbCol, 1
L = LEN(TheString)
L = MAX(0,MIN(L,40-vbCol))
IF L > 0 THEN
  TheString = LEFT$(TheString,L)
  PRINT TheString;
  vbCol = POS(0) - RightHalf
END IF
VIEW PRINT 1 TO 24
COLOR WHITE, BLACK
LOCATE MainRow, MainCol, 1
END SUB

'print EOL (clears right half of row 25)

SUB vbPutEOL()
IF DebugFlag THEN
  PRINT
END IF
MainRow = CSRLIN
MainCol = POS(0)
VIEW PRINT 25 TO 25
COLOR BLACK, WHITE
LOCATE 25,RightHalf
PRINT STRING$(79-RightHalf," ");
vbCol = 0
VIEW PRINT 1 TO 24
COLOR WHITE, BLACK
LOCATE MainRow, MainCol, 1
END SUB

'print EOL then print string

SUB vbPutEOLstr(TheString AS STRING)
CALL vbPutEOL
CALL vbPutString(TheString)
END SUB

'print integer

SUB vbPutInteger(BYVAL IntValue AS INTEGER)
Temp = STR$(IntValue)
vbPutString(Temp)
END SUB

'print long

SUB vbPutLong(BYVAL LongValue AS LONG)
Temp = STR$(LongValue)
vbPutString(Temp)
END SUB

'print hexidecimal byte

SUB vbPutHexByte(BYVAL ByteValue AS INTEGER)
Temp = HEX$(&H00FF AND ByteValue)
vbPutString(Temp)
END SUB

' print hexidecimal word

SUB vbPutHexWord(BYVAL WordValue AS INTEGER)
Temp = HEX$(ByteValue)
vbPutString(Temp)
END SUB

' test for keypress

FUNCTION vbKeyPress() AS INTEGER
IF LastChar <> "" THEN
   vbKeyPress = True
   EXIT FUNCTION
END IF
LastChar = INKEY$
IF LastChar <> "" THEN
   vbKeyPress = True
ELSE
   vbKeyPress = False
END IF
END FUNCTION

' read character from keyboard (no echo)

FUNCTION vbGetKey() AS INTEGER
DIM KeyChar AS STRING
DIM Code    AS INTEGER
DIM I       AS INTEGER
' check character returned by vbKeyPress
IF LastChar = "" THEN
   KeyChar = INPUT$(1)
ELSE
   KeyChar = LastChar
   LastChar = ""
END IF
' return key value
vbGetKey = ASC(KeyChar)
END FUNCTION

' read message

SUB vbGetString(TheString AS STRING)
DIM I AS INTEGER
DIM KeyChar AS INTEGER
I = 0
MainRow = CSRLIN
MainCol = POS(0)
VIEW PRINT 25 TO 25
COLOR BLACK, WHITE
TheString = ""
'input text from user
LOCATE 25, RightHalf+vbCol, 1
  DO
    IF vbKeyPress THEN
      KeyChar = vbGetKey
      SELECT CASE LEFT$(CHR$(KeyChar), 1)
        CASE CHR$(13)  'CR
          vbCol = POS(0) - RightHalf
          COLOR WHITE, BLACK
          VIEW PRINT 1 TO 24
          LOCATE MainRow, MainCol, 1
          EXIT SUB
        CASE CHR$(27)  'ESC to escape
          'return empty string
          TheString = ""
          COLOR WHITE, BLACK
          VIEW PRINT 1 TO 24
          LOCATE MainRow, MainCol, 1
          EXIT SUB
        CASE CHR$(8) 'backspace
          'back up if can
          IF I > 0 THEN
            'adjust buffer
            I = I - 1
            TheString = LEFT$(TheString, LEN(TheString) - 1)
            'write blank at cursor
            LOCATE 25, RightHalf + vbCol + I, 1
            PRINT " ";
            LOCATE 25, RightHalf + vbCol + I, 1
          END IF
        CASE ELSE 'not one of above special chars
          'display on bottom line
          LOCATE 25, RightHalf + vbCol + I, 1
          PRINT CHR$(KeyChar);
          'save character
          I = I + 1
          TheString = TheString + CHR$(KeyChar)
          'done ?
          IF I >= RightHalf-2 THEN
            Col = RightHalf
            VIEW PRINT 1 TO 24
            COLOR WHITE, BLACK
            LOCATE MainRow, MainCol, 1
            EXIT SUB
          END IF
      END SELECT
    END IF
  LOOP
END SUB