Power-Programmierung/CD1.mdf/basic/library/qb_pds/dos/dosbasic/demo.bas

BASIC Source File | 1990-12-19 | 13.5 KB | 535 lines

'===========================================================================
'DOS/UTILITY routines
'UPDATED 12/18/90
'ErrorHandler IS REQUIRED!!!
'Necessary for graceful recovery of errors
'===========================================================================
DEFINT A-Z
REM $INCLUDE: 'DFILE.BI'

'Draws Boxes on the Screen, I have faster MASM video routines in
'VIDBASIC.ZIP
DECLARE SUB Box (ULR%, ULC%, LRR%, LRC%, TitleMen%)
'Returns Current Filename in DOS version 3.xx and above
DECLARE SUB GetCurrentFile (FileName$)
'Gets current path and drive
DECLARE FUNCTION GetCurrPath$ ()
'Returns current physical and logical drive information
DECLARE SUB DriveInfo ()
'Select attractive cursor and screen color
DECLARE SUB BackGround ()

DIM SHARED ErrCode%
DIM SHARED PATH AS STRING * 64
CONST False = 0, True = NOT False
'saves space
DIM SHARED Zero$: Zero$ = CHR$(0)

DIM SHARED Bgrnd%  'so we can keep track of display color

CALL BackGround
CLS                'clear display to background color

ULR = 1: ULC = 1: LRR = 25: LRC = 80: TitleMen = 1
CALL Box(ULR%, ULC%, LRR%, LRC%, TitleMen%)  'draw title screen box

LOCATE 2, 15
COLOR Bgrnd%, 7
PRINT "System Information Routines (C) Copr. 1990 - SJKelly"
COLOR 7, Bgrnd%


CALL HARDRIVES(HARD%)          'select default drive"
    T$ = LEFT$(COMMAND$, 1)   'unless something different entered
    IF LEN(T$) = 0 THEN       'at command line when start program
        IF HARD% THEN
            T$ = "C"
        ELSE
            T$ = "A"
        END IF
    END IF

    T$ = UCASE$(T$)

    LOCATE 3, 15
    PRINT "Processors:    ";

    TCPU% = GETCPU%
    SELECT CASE TCPU%
        CASE 20
            PRINT "NEC V20";
        CASE 30
            PRINT "NEC V30";
        CASE ELSE
            PRINT "80" + LTRIM$(STR$(TCPU%));
    END SELECT

    TNDP% = CHECK87%
    PRINT " with";
    SELECT CASE TNDP%
        CASE 0
            PRINT "out a math";
        CASE -87
            PRINT " a software emulator";
        CASE 87
            PRINT " an 8087";
        CASE 287
            PRINT " an 80287";
        CASE 387   'cannot distinguish between 487 & 387 except for speed
            PRINT " an 80387";
        END SELECT
    PRINT " coprocessor."

    'get information about available memory
    CALL OTHERMEMORY(EXTENDED%, EXPANDED%, XMS%)
    'get some regular information too
    CALL EQUIPMENT(RegMem%, NoPrinters%, ComPorts%)

    LOCATE 5, 3
    PRINT "Memory in KB: "; RegMem%; "DOS,";
    PRINT EXPANDED%; "EMS & "; XMS%; "XMS."
    LOCATE , 3

    IF ACTUALEXTND < 0 THEN
        PRINT "CMOS battery is about dead, better replace it."
    ELSE
        PRINT "Actual Extended:"; ACTUALEXTND%; "kb"; TAB(42);
        PRINT "Free Extended:"; EXTENDED%; "kb."
    END IF

    LOCATE , 3
    Ansi = ANSICHECK%
    PRINT "ANSI Driver:   ";
    IF Ansi THEN
        PRINT "IS installed.";
    ELSE
        PRINT "NOT installed.";
    END IF
    PRINT

    VERSION$ = SPACE$(4)
    CALL GETDOSVER(VERSION$)
    LOCATE , 3
    PRINT "DOS Version:   "; VERSION$;

    'check if we are operating under a multitasking environment
    CALL OTHEROPER(DPMI%, WINDOWS%, DESQVIEW)
    PRINT TAB(42); "Multitasker:";
    IF (DPMI + WINDOWS + DESQVIEW) THEN
         IF DPMI% THEN PRINT " DPMI";
         IF WINDOWS% THEN PRINT " WINDOWS";
         IF DESQVIEW% THEN PRINT " DESQVIEW";
         PRINT
    ELSE
        PRINT " None."
    END IF
    PRINT

    LOCATE , 3
    FOR x = 1 TO NoPrinters
        IF PRINTRDY%(x) THEN
            PRINT "LPT"; CHR$(x + 48); ": printer ready.   ";
        ELSE
            PRINT "LPT"; CHR$(x + 48); ": printer error.   ";
        END IF
    NEXT
    PRINT

    LOCATE , 3
    PRINT "You have"; ComPorts; "COM ports installed."
    PRINT

    CALL GetCurrentFile(FileName$)
    LOCATE , 3
    PRINT "Current file name:  "; FileName$

    IF LEN(FileName$) = 0 THEN FileName$ = "QB.EXE"

'need to trap open doors & invalid drives
ON ERROR GOTO ErrorHandler

    'strip off the leading drive and subdirectory names
    DO
        FileName$ = MID$(FileName$, INSTR(FileName$, "\") + 1)
        IF INSTR(FileName$, "\") = 0 THEN EXIT DO
    LOOP

    Mode% = 0  '0 means normal read access, <> 0 means read/write access
    CALL EXIST(FileName$ + Zero$, ErrCode%, Mode%)

    LOCATE , 3
    IF ErrCode% THEN
        PRINT "Sorry, "; FileName$; " not found in current directory."
    ELSE
        PRINT FileName$; " found in current directory."
    END IF

    FirstDrive$ = "z:"
    CALL GETDRIVE(FirstDrive$)

    LOCATE , 3
    PRINT "Changing Drive to Drive "; T$; ":";
    CALL SETDRIVE(T$, ErrCode%)

    LOCATE , 3
    IF ErrCode% THEN
        PRINT "Drive invalid, old value retained.";
    ELSE
        CALL SUBSTDRIVE(T$, ErrCode%)
        IF (ErrCode% = 2) THEN
            PRINT "Drive "; T$; " is a SUBST drive."
        ELSE
            PRINT
        END IF
    END IF


    LOCATE , 3
    PRINT "Current Drive and Path is "; GetCurrPath$;
        IF ErrCode% THEN
            PRINT " Error reported."
        ELSE
            PRINT
        END IF

    CALL DRVSPACE(T$, F&)
    LOCATE , 3
    IF F& = 0 THEN
        PRINT "Selected drive was invalid."
    ELSE
        PRINT "Drive "; T$; ": has";
        PRINT USING "##########,"; F&;
        PRINT " Bytes free."
    END IF
    PRINT

    'return to where we started, assume still valid
    LOCATE , 3
    PRINT "Returning to Original Drive: "; FirstDrive$
    CALL SETDRIVE(FirstDrive$, ErrCode%)

'turn off error checking to show how the following routines work
ON ERROR GOTO 0

CALL DriveInfo

LOCATE 23, 1

DO        'Wait until Key press
LOOP UNTIL LEN(INKEY$)

SCREEN 0, , 0, 0
CLS
ULR = 9: ULC = 1: LRR = 25: LRC = 80: TitleMen = 1
CALL Box(ULR%, ULC%, LRR%, LRC%, TitleMen%)  'draw title screen box

LOCATE 10, 3
PRINT "The MASM routines used by this DEMO are";
LOCATE 11, 9

TemHead$ = "Copr. Copyright (C) 1990, Sidney J. Kelly, All rights Reserved."
PRINT TemHead$;
LOCATE 13, 3
PRINT "Your ROM BIOS shows the following information:"
LOCATE 15, 3
PRINT "ROM BIOS date is: "; SPC(24);
RomDate$ = SPACE$(8)
SegAddress% = &HFFFF: OffAddress% = &H5
CALL MEM2STRING(RomDate$, SegAddress%, OffAddress%)
PRINT RomDate$

LOCATE 16, 3
CopyRight$ = SPACE$(90)
SegAddress% = &HFE00: OffAddress% = &H0
CALL MEM2STRING(CopyRight$, SegAddress%, OffAddress%)
Temp$ = UCASE$(CopyRight$)  'squeeze out unnecessary information
Lengt = LEN(CopyRight$)
Temp = INSTR(Temp$, "CO")
CopyRight$ = RTRIM$(RIGHT$(CopyRight$, Lengt - Temp + 1))
PRINT "ROM: "; CopyRight$

LOCATE 18, 3
CALL DRIVEALIAS(ASSIGN%, DAPPEND%, NETWORK%, SHARE%)
PRINT "ASSIGN is: ";
IF ASSIGN THEN
    PRINT "active.   ";
ELSE
    PRINT "inactive.   ";
END IF

PRINT TAB(32); "APPEND is: ";
IF DAPPEND THEN
    PRINT "active."
ELSE
    PRINT "inactive."
END IF

LOCATE 19, 3

PRINT "MS NETWORK is: ";
IF NETWORK THEN
    PRINT "active.   ";
ELSE
    PRINT "inactive.   ";
END IF

PRINT TAB(32); "SHARE is: ";
IF SHARE THEN
    PRINT "active."
ELSE
    PRINT "inactive."
END IF

LOCATE 24, 27
COLOR Bgrnd%, 7
PRINT "Press any key to quit.";
COLOR 7, Bgrnd%

DO        'Wait until Key press
LOOP UNTIL LEN(INKEY$)

CLS
LOCATE 10, 3
PRINT "The MASM routines used by this DEMO are now printed backwards";
LOCATE 11, 1

CALL REVERSESTRING(TemHead$)
PRINT TemHead$
SLEEP 1

CALL REVERSESTRING(TemHead$)
PRINT TemHead$
SLEEP 1

'need an end to avoid crashing into ErrorHandler
END

'Necessary for graceful recovery of errors
ErrorHandler:
    SELECT CASE ERR
        CASE 53, 76   'File does not exist, an expected error
            RESUME NEXT
        CASE 75       'File does not exist, an expected error
            RESUME NEXT
        CASE 57, 68   'Drive is invalid generating an I/O error
            ErrCode = True
            RESUME NEXT
        CASE 64       '"Bad filename", an expected error
            RESUME NEXT
        CASE 71                  'door open on the drive
            ErrCode% = True
            RESUME NEXT
        CASE ELSE
            LOCATE , 3
            PRINT " Error occurred:"; ERR
    END SELECT

'==============================Background===================================
' Selects a nice background and cursor size
' depending on the type of CRT
' QBASIC selects a cursor that is properly sized only for the CGA
' Updated 1/9/90
'===========================================================================
SUB BackGround STATIC
    'Check BIOS area of RAM
    DEF SEG = &H40
    'CRTMode = PEEK(&H63)     'Check CRT port
    IF PEEK(&H63) = &HB4 THEN
        'if CRTMode = &HB4  then CRTMode is a Mono display
        Bgrnd% = 0           'use a black background
        LOCATE , , , 12, 13  'Pleasant cursor size
    ELSE
        'else a Color display (correct for EGA/VGA only if cursor
                         'emulation is on).
        Bgrnd% = 1           'use a blue background.  However,
                         'on a COMPAQ portable or EGA/VGA monochrome
                         'this is NOT attractive.
        LOCATE , , , 6, 7    'Pleasant cursor size
    END IF
    COLOR 7, Bgrnd%
    'restore Def Seg
    DEF SEG

'Note a VGA can appear as a color or mono display depending upon
'the current BIOS mode and depending if monitor was on when the machine
'was turned on.

END SUB

'------------------------------Draw Boxes------------------------------------
' DRAW A BOX AT SPECIFIED COORDINATES
' This is a generic routine that can be used to draw a box anywhere.
' ULR% is the starting row. ULC% is the starting column.
' LRR% is the ending row. LRC% is the ending column.
' If the paramater TitleMen% is > 0, then prints horizontal bars
' three rows down from the top of the box and two rows up from the bottom.
' If TitleMen% is set to 0, the routine will print a plain box.
' This can create a quick frame for a title screen.
'
' In my VIDBASIC library is a much faster MASM routine.  This routine is
' added because it is generic and needs no MASM support
'----------------------------------------------------------------------------
SUB Box (ULR%, ULC%, LRR%, LRC%, TitleMen%) STATIC

'to make the definitions local to routine
STATIC BoxTop, BoxTop$, BoxBottom$, BoxMiddle$

'CONST is used for speed
CONST BoxSide$ = "║"  'box side    CHR$(186)
CONST UpLeft$ = "╔"   'upper left  CHR$(201)
CONST UpRight$ = "╗"  'upper right CHR$(187)
CONST LowLeft$ = "╚"  'lower left  CHR$(200)
CONST LowRight$ = "╝" 'lower right CHR$(188)
CONST LeftTee$ = "╠"  'left T      CHR$(204)
CONST RightTee$ = "╣" 'right T     CHR$(185)

'The first piece of code sets up the strings for box drawing
BoxTop = (LRC% - ULC%) - 1
IF BoxTop < 0 THEN BoxTop = 0        'keep variable within range

BoxTop$ = UpLeft$ + STRING$(BoxTop, 205) + UpRight$
BoxBottom$ = LowLeft$ + STRING$(BoxTop, 205) + LowRight$

'This prints the top of the box
LOCATE ULR%, ULC%: PRINT BoxTop$;

'Print the sides of the box
FOR E1% = ULR% + 1 TO LRR% - 1
    LOCATE E1%, ULC%: PRINT BoxSide$;
    LOCATE E1%, LRC%: PRINT BoxSide$;
NEXT

'Print the bottom of the box
LOCATE LRR%, ULC%: PRINT BoxBottom$;

'Optionally prints horizontal lines at top and bottom of the box
'To set up title and menu screens.
IF TitleMen% > 0 THEN
    BoxMiddle$ = LeftTee$ + STRING$(BoxTop, 205) + RightTee$
    LOCATE ULR% + 3, ULC%: PRINT BoxMiddle$;
    LOCATE LRR% - 2, ULC%: PRINT BoxMiddle$;
END IF

'speed up garbage collection and allow use of STATIC
 BoxTop$ = "": BoxBottom$ = "": BoxMiddle$ = ""

END SUB

'===========================================================================
' Returns information concerning logical and physical drives
'
' Updated 6/20/90
'===========================================================================
SUB DriveInfo STATIC

    DirNos% = FINDDRIVES%
    LOCATE , 3
    PRINT "Logical  Drives: ";
    PRINT " A: to " + CHR$(64 + DirNos%) + ":"

    CALL FLOPPYDRIVES(NoDrives%)
    CALL HARDRIVES(HARD%)

    LOCATE , 3
    PRINT "Physical Drives: "; HARD%;
    PRINT "Hard Drive(s),"; NoDrives%; "Floppy Drive(s)."

    LOCATE , 3
    IF NoDrives = 1 THEN
        DEF SEG = 0
        Mimic = PEEK(&H504)
        DEF SEG
        PRINT "Drive A: is currently acting as Drive ";

        'Mimic = 0 if acting as A:, 1 if B: and 255 if never used drive A
        IF (Mimic = 1) THEN
            PRINT "B:"
        ELSE
            PRINT "A:"
        END IF
    END IF

    Drive$ = "A:"
    CALL FLOPPYREADY(Drive$, ErrCode%)
    LOCATE 24, 3
    PRINT "Floppy Drive "; Drive$;

    SELECT CASE ErrCode%
        CASE 0
            PRINT " is valid and has the door closed.";
        CASE 128
            PRINT " has its door open.";
        CASE 80
            PRINT " has a track error.";
        CASE -1
            PRINT " is not valid.";
    END SELECT

END SUB

'===========================================================================
' Returns the current running file name based on the current
' PSP for the program.
' Works in DOS version 3.xx and above.
' Inside QB.EXE will always report QB.EXE
' Updated 7/20/90
'===========================================================================
SUB GetCurrentFile (FileName$) STATIC

    FileName$ = SPACE$(64)
    CALL GETCURRENTNAME(FileName$, FileNameLen%)

    IF FileNameLen% > 0 THEN
        FileName$ = UCASE$(LEFT$(FileName$, FileNameLen%))
    ELSE
        FileName$ = ""
    END IF

END SUB

'===========================================================================
' Returns Complete Current Drive and Path$
' Also detects if SUBST, ASSIGN, JOIN are at work
' Updated 9/26/90
'===========================================================================
FUNCTION GetCurrPath$ STATIC

    STATIC D$, T$, P$

    ErrCode% = False%
    T$ = SPACE$(67)
    CALL GETFULLPATH(T$, PATHLEN%)

    IF (PATHLEN% = -1) OR ErrCode% THEN
        GetCurrPath$ = ""
        T$ = ""
        EXIT FUNCTION
    END IF

    T$ = LEFT$(T$, PATHLEN%)

    D$ = ".": P$ = SPACE$(67)
    CALL TRUENAME(D$ + Zero$, P$, FileLen%)
    SELECT CASE FileLen
        CASE 0
            'Dos Version 2.xx so TrueName wont work & SHARE, ASSIGN
            'SUBST, & JOIN are by definition inactive
        CASE -1
            PRINT " Current Path$ contains unknown error.": END
        CASE 1 TO 67
            P$ = LEFT$(P$, FileLen%)
            IF P$ <> T$ THEN
                PRINT " Warning! ASSIGN, JOIN, or SUBST active."
                PRINT " Please remove from BATCH files and reboot!!"
                T$ = "Error r r r"
            END IF
        CASE ELSE
    END SELECT

    GetCurrPath$ = T$

    T$ = "": D$ = "": P$ = ""

END FUNCTION