Power-Programmierung/CD1.mdf/basic/library/qb_pds/database/jdb10/jdb.bas

BASIC Source File | 1993-12-19 | 12.7 KB | 455 lines

'PROGRAM NAME: JDB.BAS, Joe's DataBase
'WRITTEN BY  : Joe Caverly
'              J&T Data Pros
'              St. Thomas, Ontario
'VERSION     : 1.0, 93/12/19
'NOTES       : This is a QBASIC Program which I am developing. Your input
'              and questions are requested. This software and accompanying
'              materials are distributed "as is" without charge and without
'              warranty, express, implied or statutory, including but not
'              limited to any implied warranties of merchantability and
'              fitness for a particular purpose.  In no event shall anyone
'              involved with the creation and production of this product be
'              liable for indirect, special, or consequential damages,
'              arising out of any use thereof or breach of any warranty.
'
'              You may not upload modified versions of the code to any
'              electronic BBS. All changes must be sent to me for inclusion
'              in the program, at which time you will be given credit in the
'              program for your contribution.
'
'              You may upload this program, as is and unmodified, to any
'              electronic BBS. In fact, I request that you do so, in order
'              for me to receive feedback from all those interested. I can be
'              reached at the Home Office Business Exchange BBS 519-633-6574
'              or Internet [e-mail].

CONST FALSE = 0
CONST TRUE = NOT FALSE

' Key code numbers
CONST BACKSPACE = 8
CONST CTRLLEFTARROW = 29440
CONST CTRLRIGHTARROW = 29696
CONST CTRLY = 25
CONST CTRLQ = 17
CONST DELETE = 21248
CONST DOWNARROW = 20480
CONST ENDKEY = 20224
CONST ENTER = 13
CONST ESCAPE = 27
CONST HOME = 18176
CONST INSERTKEY = 20992
CONST LEFTARROW = 19200
CONST RIGHTARROW = 19712
CONST TABKEY = 9
CONST UPARROW = 18432

' Functions
DECLARE FUNCTION KeyCode% ()
DECLARE FUNCTION InKeyCode% ()

' Subprograms
DECLARE SUB Editline (a$, exitcode%)

' If there is an error, process it
ON ERROR GOTO ErrHandler

' A variable indicating the maximum number of records in the file
LET MaxRecs = 200
LET Choice = 0

' Define the structure of the data record
TYPE DataDef
  Status AS STRING * 1
  LastName AS STRING * 15
  FirstName AS STRING * 10
  City AS STRING * 15
  Province AS STRING * 2
  PostalCode AS STRING * 6
  Telephone AS STRING * 10
END TYPE

' Indicate how many records can be in the file
DIM Record(1 TO MaxRecs) AS DataDef

' Determine the File Size
LET FileSize = MaxRecs * LEN(Record(1))

' Load The File Into The Memory Array
GOSUB LoadFile

' Display Main Menu
DO WHILE Choice <> 5
  GOSUB MainMenu
LOOP

' End of Program
END

' Add A Record To The File
AddARecord:
  SR$ = "ADDARECORD"                    'Indicate the current subroutine
  LastName$ = STRING$(LEN(Record(1).LastName), " ")
  FirstName$ = STRING$(LEN(Record(1).FirstName), " ")
  City$ = STRING$(LEN(Record(1).City), " ")
  Province$ = STRING$(LEN(Record(1).Province), " ")
  PostalCode$ = STRING$(LEN(Record(1).PostalCode$), " ")
  Telephone$ = STRING$(LEN(Record(1).Telephone), " ")
  CLS
  LOCATE 1, 1: PRINT "Last Name   "
  LOCATE 2, 1: PRINT "First Name  "
  LOCATE 3, 1: PRINT "City        "
  LOCATE 4, 1: PRINT "Province    "
  LOCATE 5, 1: PRINT "Postal Code "
  LOCATE 6, 1: PRINT "Telephone   "
  COLOR 14, 1
  LOCATE 1, 14: Editline LastName$, exitcode%
  LOCATE 2, 14: Editline FirstName$, exitcode%
  LOCATE 3, 14: Editline City$, exitcode%
  LOCATE 4, 14: Editline Province$, exitcode%
  LOCATE 5, 14: Editline PostalCode$, exitcode%
  LOCATE 6, 14: Editline Telephone$, exitcode%
  COLOR 7, 0
  IF LastName$ = STRING$(LEN(Record(1).LastName), " ") THEN
    'Next Sentence
  ELSE
    GOSUB SaveARecord
  END IF
RETURN

DeleteARecord:
  SR$ = "DELETEARECORD"
  INPUT "Record To Delete:"; RecToDel
  IF RecToDel > 0 AND RecToDel < MaxRecs THEN
    PRINT Record(RecToDel).LastName
    PRINT Record(RecToDel).FirstName
    PRINT Record(RecToDel).City
    PRINT Record(RecToDel).Province
    PRINT Record(RecToDel).PostalCode
    PRINT Record(RecToDel).Telephone
    PRINT
    INPUT "Delete This Record (Y/N)"; YorN$
    IF YorN$ = "Y" OR YorN$ = "y" THEN
      Record(RecToDel).Status = " "
      GOSUB SaveFile
    END IF
  END IF
RETURN

DisplayAll:
  SR$ = "DISPLAYALL"
  FOR RecCtr = 1 TO MaxRecs
    IF Record(RecCtr).Status = "A" THEN
      PRINT RecCtr;
      PRINT Record(RecCtr).LastName;
      PRINT Record(RecCtr).FirstName
    END IF
  NEXT RecCtr
  PRINT
  PRINT "Press the <Space Bar> to continue..."
  WHILE INKEY$ = "": WEND
RETURN

MainMenu:
  SR$ = "MAINMENU"
  CLS
  PRINT "1) Add A Record"
  PRINT "2) Change A Record"
  PRINT "3) Delete A Record"
  PRINT "4) Display All"
  PRINT "5) Quit"
  INPUT Choice

  SELECT CASE Choice
    CASE 1
      GOSUB AddARecord
    CASE 3
      GOSUB DeleteARecord
    CASE 4
      GOSUB DisplayAll
    CASE otherwise
      PRINT CHR$(7)
  END SELECT
RETURN

SaveARecord:
  SR$ = "SAVEARECORD"
  FoundEmpty$ = "N"
  FOR RecCtr = 1 TO MaxRecs
    IF Record(RecCtr).Status <> "A" AND FoundEmpty$ = "N" THEN
      LET Record(RecCtr).Status = "A"
      LET Record(RecCtr).LastName = LastName$
      LET Record(RecCtr).FirstName = FirstName$
      LET Record(RecCtr).City = City$
      LET Record(RecCtr).Province = Province$
      LET Record(RecCtr).PostalCode = PostalCode$
      LET Record(RecCtr).Telephone = Telephone$
      GOSUB SaveFile
      FoundEmpty$ = "Y"
    END IF
  NEXT RecCtr
  IF FoundEmpty$ = "N" THEN
    PRINT "File is Full"
  END IF
RETURN

SaveFile:
  SR$ = "SAVEFILE"
  DEF SEG = VARSEG(Record(1))
  BSAVE "JDB.DAT", 0, FileSize
RETURN

LoadFile:
  SR$ = "LOADFILE"
  DEF SEG = VARSEG(Record(1))
  BLOAD "JDB.DAT", 0
RETURN

ErrHandler:
  SELECT CASE ERR
    CASE 53
      IF SR$ = "LOADFILE" THEN
        GOSUB SaveFile
        RESUME
      END IF
    CASE ELSE
      PRINT ERR
      PRINT SR$
      END
  END SELECT
END

SUB Editline (a$, exitcode%) STATIC
  ' ************************************************
  ' **  Name:          EditLine                   **
  ' **  Type:          Subprogram                 **
  ' **  Module:        EDIT.BAS                   **
  ' **  Language:      Microsoft QuickBASIC 4.00  **
  ' ************************************************
  '
  ' Allows the user to edit a string at the current cursor position
  ' on the screen.  Keys acted upon are Ctrl-Y, Ctrl-Q-Y, Right
  ' arrow, Left arrow, Ctrl-Left arrow, Ctrl-Right arrow, Home, End,
  ' Insert, Escape, Backspace, and Delete.
  ' Pressing Enter, Up arrow, or Down arrow terminates
  ' the subprogram and returns exitCode% of 0, +1, or -1.
  '
  ' EXAMPLE OF USE:  EditLine a$, exitCode%
  ' PARAMETERS:      a$         String to be edited
  '                  exitCode%  Returned code indicating the terminating
  '                             key press
  ' VARIABLES:       row%       Saved current cursor row
  '                  col%       Saved current cursor column
  '                  length%    Length of a$
  '                  ptr%       Location of cursor during the editing
  '                  insert%    Insert mode toggle
  '                  quit%      Flag for quitting the editing
  '                  original$  Saved copy of starting a$
  '                  keyNumber% Integer code for any key press
  '                  ctrlQflag% Indicates Ctrl-Q key press
  '                  kee$       Character of key just pressed
  '                  sp%        Length of space string
  ' MODULE LEVEL
  '   DECLARATIONS:  DECLARE FUNCTION KeyCode% ()
  '                  DECLARE SUB EditLine (a$, exitCode%)
  '

  ' Set up some variables
  row% = CSRLIN
  col% = POS(0)
  length% = LEN(a$)
  ptr% = 0
  insert% = TRUE
  quit% = FALSE
  original$ = a$

' Main processing loop
  DO

    ' Display the line
      LOCATE row%, col%, 0
      PRINT a$;

    ' Show appropriate cursor type
      IF insert% THEN
          LOCATE row%, col% + ptr%, 1, 6, 7
      ELSE
          LOCATE row%, col% + ptr%, 1, 1, 7
      END IF

    ' Get next keystroke
      keyNumber% = KeyCode%

    ' Process the key
      SELECT CASE keyNumber%

      CASE INSERTKEY
          IF insert% THEN
              insert% = FALSE
          ELSE
              insert% = TRUE
          END IF

      CASE BACKSPACE
          IF ptr% THEN
              a$ = a$ + " "
              a$ = LEFT$(a$, ptr% - 1) + MID$(a$, ptr% + 1)
              ptr% = ptr% - 1
          END IF

      CASE DELETE
          a$ = a$ + " "
          a$ = LEFT$(a$, ptr%) + MID$(a$, ptr% + 2)

      CASE UPARROW
          exitcode% = 1
          quit% = TRUE

      CASE DOWNARROW
          exitcode% = -1
          quit% = TRUE

      CASE LEFTARROW
          IF ptr% THEN
              ptr% = ptr% - 1
          END IF

      CASE RIGHTARROW
          IF ptr% < length% - 1 THEN
              ptr% = ptr% + 1
          END IF

      CASE ENTER
          exitcode% = 0
          quit% = TRUE

      CASE HOME
          ptr% = 0

      CASE ENDKEY
          ptr% = length% - 1

      CASE CTRLRIGHTARROW
          DO UNTIL MID$(a$, ptr% + 1, 1) = " " OR ptr% = length% - 1
              ptr% = ptr% + 1
          LOOP
          DO UNTIL MID$(a$, ptr% + 1, 1) <> " " OR ptr% = length% - 1
              ptr% = ptr% + 1
          LOOP

      CASE CTRLLEFTARROW
          DO UNTIL MID$(a$, ptr% + 1, 1) = " " OR ptr% = 0
              ptr% = ptr% - 1
          LOOP
          DO UNTIL MID$(a$, ptr% + 1, 1) <> " " OR ptr% = 0
              ptr% = ptr% - 1
          LOOP
          DO UNTIL MID$(a$, ptr% + 1, 1) = " " OR ptr% = 0
              ptr% = ptr% - 1
          LOOP
          IF ptr% THEN
              ptr% = ptr% + 1
          END IF

      CASE CTRLY
          a$ = SPACE$(length%)
          ptr% = 0

      CASE CTRLQ
          ctrlQflag% = TRUE

      CASE ESCAPE
          a$ = original$
          ptr% = 0
          insert% = TRUE

      CASE IS > 255
          SOUND 999, 1

      CASE IS < 32
          SOUND 999, 1

      CASE ELSE

        ' Convert key code to character string
          kee$ = CHR$(keyNumber%)

        ' Insert or overstrike
          IF insert% THEN
              a$ = LEFT$(a$, ptr%) + kee$ + MID$(a$, ptr% + 1)
              a$ = LEFT$(a$, length%)
          ELSE
              IF ptr% < length% THEN
                  MID$(a$, ptr% + 1, 1) = kee$
              END IF
          END IF

        ' Are we up against the wall?
          IF ptr% < length% THEN
              ptr% = ptr% + 1
          ELSE
              SOUND 999, 1
          END IF

        ' Special check for Ctrl-Q-Y (del to end of line)
          IF kee$ = "y" AND ctrlQflag% THEN
              IF ptr% <= length% THEN
                  sp% = length% - ptr% + 1
                  MID$(a$, ptr%, sp%) = SPACE$(sp%)
                  ptr% = ptr% - 1
              END IF
          END IF

        ' Clear out the Ctrl-Q signal
          ctrlQflag% = FALSE

      END SELECT

  LOOP UNTIL quit%

END SUB

FUNCTION InKeyCode% STATIC
  ' ************************************************
  ' **  Name:          InKeyCode%                 **
  ' **  Type:          Function                   **
  ' **  Module:        KEYS.BAS                   **
  ' **  Language:      Microsoft QuickBASIC 4.00  **
  ' ************************************************
  '
  ' Returns a unique integer for any key pressed or
  ' a zero if no key was pressed.
  '
  ' EXAMPLE OF USE:  k% = InKeyCode%
  ' PARAMETERS:      (none)
  ' VARIABLES:       (none)
  ' MODULE LEVEL
  '   DECLARATIONS:  DECLARE FUNCTION KeyCode% ()
  '
  InKeyCode% = CVI(INKEY$ + STRING$(2, 0))
END FUNCTION

FUNCTION KeyCode% STATIC
  ' ************************************************
  ' **  Name:          KeyCode%                   **
  ' **  Type:          Function                   **
  ' **  Module:        KEYS.BAS                   **
  ' **  Language:      Microsoft QuickBASIC 4.00  **
  ' ************************************************
  '
  ' Returns a unique integer for any key pressed.
  '
  ' EXAMPLE OF USE:  k% = KeyCode%
  ' PARAMETERS:      (none)
  ' VARIABLES:       (none)
  ' MODULE LEVEL
  '   DECLARATIONS:  DECLARE FUNCTION KeyCode% ()
  '
  DO
      k$ = INKEY$
  LOOP UNTIL k$ <> ""
  KeyCode% = CVI(k$ + CHR$(0))
END FUNCTION