CD Actual 15/CDACTUAL15.iso/cdactual/program/basic/QBSCR20.ZIP/3D.BAS

BASIC Source File | 1992-07-08 | 20.7 KB | 490 lines

'┌────────────────────────────────────────────────────────────────────────┐
'│                                                                        │
'│                              3 D . B A S                               │
'│                                                                        │
'│                   Supplementary Source Code for the                    │
'│       The QBSCR Screen Routines for QuickBASIC 4.0+ Programmers        │
'│                              Version 2.0                               │
'│                                                                        │
'│                   (C) Copyright 1992 by Tony Martin                    │
'│                                                                        │
'├────────────────────────────────────────────────────────────────────────┤
'│                                                                        │
'│  This source code is copyright 1992 by Tony Martin.  You may change    │
'│  it to suit your programming needs, but you may not distribute any     │
'│  modified copies of the library itself.  I retain all rights to the    │
'│  source code and all library modules included with the QBSCR package,  │
'│  as well as to the example programs.  You may not remove this notice   │
'│  from any copies of the library itself you distribute.                 │
'│                                                                        │
'│  You are granted the right to use this source code for your own pro-   │
'│  grams, without royalty payments or credits to me (though, if you      │
'│  feel so inclined to give me credit, feel free to do so).  You MUST    │
'│  register this software if you release a shareware or commercial       │
'│  program that uses it.  You may use these routines in any type of      │
'│  software you create, as long as it is not a programming toolbox or    │
'│  package of routines OF ANY KIND.                                      │
'│                                                                        │
'│  This package is shareware.  If you find it useful or use it in any    │
'│  software you release, you are requested to send a registration fee of │
'│  $25.00 (U.S. funds only) to:                                          │
'│                                                                        │
'│                            Tony Martin                                 │
'│                       1611 Harvest Green Ct.                           │
'│                          Reston, VA 22094                              │
'│                                                                        │
'│  All registered users receive an 'official' disk set containing the    │
'│  latest verison of the QBSCR routines.  For more information, see      │
'│  the QBSCR documentation.                                              │
'│                                                                        │
'├────────────────────────────────────────────────────────────────────────┤
'│                                                                        │
'│  For information on using these routines and incorporating them into   │
'│  your own programs, see the accompanying documentation.                │
'│                                                                        │
'└────────────────────────────────────────────────────────────────────────┘

REM $INCLUDE: 'mouse.bi'

CONST FLUSHLEFT = 0
CONST FLUSHRIGHT = 1
CONST CENTERED = 2

CONST SINGLEBORDER = 0        ' Single-line border for buttons and boxes
CONST DOUBLEBORDER = 1        ' Double-line border for buttons and boxes

CONST STYLE3D = 0
CONST STYLE2D = 1

CONST EMmoved = -1            ' getEvent code: Mouse Moved
CONST EMpressedLeft = -2      ' getEvent code: Mouse left button pressed
CONST EMpressedRight = -3     ' getEvent code: Mouse right button pressed
CONST EMpressedCenter = -4    ' getEvent code: Mouse center button pressed
CONST EMreleasedLeft = -5     ' getEvent code: Mouse left button releases
CONST EMreleasedRight = -6    ' getEvent code: Mouse right button released
CONST EMreleasedCenter = -7   ' getEvent code: Mouse center button released
CONST EKpressed = -8          ' getEvent code: Key on keyboard pressed

CONST F1 = 15104              ' Unique integers (scan codes) for special
CONST F2 = 15360              ' keys.  May be used to refer to codes returned
CONST F3 = 15616              ' by getEvent function by name.
CONST F4 = 15872
CONST F5 = 16128
CONST F6 = 16384
CONST F7 = 16640
CONST F8 = 16896
CONST F9 = 17152
CONST F10 = 17408
CONST UPARROW = 18432
CONST DOWNARROW = 20480
CONST LEFTARROW = 19200
CONST RIGHTARROW = 19712
CONST HOMEKEY = 18176
CONST ENDKEY = 20224
CONST PGUP = 18688
CONST PGDN = 20736
CONST INSERT = 20992
CONST DELETE = 21248

DECLARE FUNCTION getEvent% (checkMouse%, keyCode%, mouseX%, mouseY%)
DECLARE SUB DepressedBox (boxType%, x1%, y1%, x2%, y2%, fg%, bg%, buttonStyle%)
DECLARE SUB DrawButton (buttonType%, x1%, y1%, x2%, y2%, fg%, bg%, txt$, buttonStyle%)
DECLARE SUB PressButton (buttonType%, x1%, y1%, x2%, y2%, fg%, bg%, txt$, buttonStyle%)
DECLARE SUB PressedButton (buttonType%, x1%, y1%, x2%, y2%, fg%, bg%, txt$, buttonStyle%)
DECLARE SUB RaisedBox (boxType%, x1%, y1%, x2%, y2%, fg%, bg%, buttonStyle%)

COMMON SHARED mouseExists%, mouseState%

SUB DepressedBox (boxType%, x1%, y1%, x2%, y2%, fg%, bg%, buttonStyle%)

    ' ────────────────────────────────────────────────────────────────────────
    '  This function displays a 3D box that appears to be depressed into the
    '  screen. The boxType% parameter is either SINGLEBORDER or DOUBLEBORDER,
    '  both of which are defined in QBSCR.INC.  The buttonStyle% parameter is
    '  either STYLE3D or STYLE2D, both of which are defined in QBSCR.INC. The
    '  button style STYLE3D is used for color displays or 3D interfaces,
    '  while STYLE2D is used for monochrome or non-3D interfaces.
    ' ────────────────────────────────────────────────────────────────────────

    ' ────────────────────────────────────────────────────────────────────────
    '  Define the box drawing characters based on the boxType%.
    ' ────────────────────────────────────────────────────────────────────────
    IF boxType% = SINGLEBORDER THEN
        ulc$ = CHR$(218)
        urc$ = CHR$(191)
        ver$ = CHR$(179)
        hor$ = CHR$(196)
        llc$ = CHR$(192)
        lrc$ = CHR$(217)
    END IF
    IF boxType% = DOUBLEBORDER THEN
        ulc$ = CHR$(201)
        urc$ = CHR$(187)
        ver$ = CHR$(186)
        hor$ = CHR$(205)
        llc$ = CHR$(200)
        lrc$ = CHR$(188)
    END IF

    ' ────────────────────────────────────────────────────────────────────────
    '  If buttonStyle% is STYLE2D, draw a simple box.
    ' ────────────────────────────────────────────────────────────────────────
    IF buttonStyle% = STYLE2D THEN
        COLOR fg%, bg%
        LOCATE y1%, x1%, 0: PRINT ulc$; STRING$(x2% - x1% - 1, hor$); urc$;
        FOR i% = y1% + 1 TO y2% - 1
            LOCATE i%, x1%, 0: PRINT ver$;
            LOCATE i%, x2%, 0: PRINT ver$;
        NEXT i%
        LOCATE y2%, x1%, 0: PRINT llc$; STRING$(x2% - x1% - 1, hor$); lrc$;
        EXIT SUB
    END IF

    ' ────────────────────────────────────────────────────────────────────────
    '  The rest of the code is dedicated to drawing a 3D shaded box.  The
    '  top and left sides are drawn in a black foreground, and the bottom and
    '  right sides are drawn in a white foreground.  This gives the appearance
    '  of a shaded box that is depressed into the screen.
    ' ────────────────────────────────────────────────────────────────────────
    COLOR 0, bg%                              ' Draw the top side.
    LOCATE y1%, x1%, 0: PRINT ulc$;
    PRINT STRING$(x2% - x1% - 1, hor$);
    COLOR 15, bg%
    PRINT urc$;

    FOR i% = y1% + 1 TO y2% - 1               ' Draw the left and right sides.
        LOCATE i%, x1%, 0: COLOR 0, bg%: PRINT ver$;
        LOCATE i%, x2%, 0: COLOR 15, bg%: PRINT ver$;
    NEXT i%

    COLOR 0, bg%                              ' Draw the bottom side.
    LOCATE y2%, x1%, 0: PRINT llc$;
    COLOR 15, bg%
    PRINT STRING$(x2% - x1% - 1, hor$);
    PRINT lrc$;

END SUB

SUB DrawButton (buttonType%, x1%, y1%, x2%, y2%, fg%, bg%, txt$, buttonStyle%)

    ' ────────────────────────────────────────────────────────────────────────
    '  This routine draws a button on the screen with a text label inside it.
    '  The buttonType% is either SINGLEBORDER or DOUBLEORDER, and the button-
    '  Style%  is either STYLE3D or STYLE2D.  All these constants are defined
    '  in QBSCR.INC. It will appear to be raised from the screen.
    ' ────────────────────────────────────────────────────────────────────────

    ' ────────────────────────────────────────────────────────────────────────
    '  Use the RaisedBox routine to draw the basic button border.
    ' ────────────────────────────────────────────────────────────────────────
    RaisedBox buttonType%, x1%, y1%, x2%, y2%, fg%, bg%, buttonStyle%

    ' ────────────────────────────────────────────────────────────────────────
    '  Add the text to the button, centered (left-right) in the button.
    ' ────────────────────────────────────────────────────────────────────────
    LOCATE y1% + 1, (((x2% - x1%) - LEN(txt$)) \ 2) + x1% + 1, 0
    COLOR fg%, bg%
    PRINT txt$

END SUB

'***************************************************************************
'*  Function: getEvent                                                     *
'*  Purpose:  Obtain keyboard and mouse events and return them.            *
'*  Params:   checkMouse% (IN): If TRUE (non-zero), causes this routine    *
'*            to check the mouse.  If FALSE (zero), this routine will      *
'*            NOT check the mouse for events.                              *
'*            keyCode% (OUT): On return, contains scan code or ASCII code  *
'*            of the key that was pressed on the keyboard.  If the key     *
'*            was a normal character, it returns the ASCII code.  If it    *
'*            was a special key (like a function or arrow key), it returns *
'*            a unique integer.  See QBSCR_3D.BI for these integers.       *
'*            mouseX% (OUT): Current X-coordinate of mouse if mouse event  *
'*            occurred.                                                    *
'*            mouseY% (OUT): Current Y-coordinate of mouse if mouse event  *
'*            occurred.                                                    *
'*  Returns:  A predefined code that identified the type of event that     *
'*            occurred.  They are named constants in the QBSCR_3D.BI file  *
'*            and are also duplicated here:                                *
'*                                                                         *
'*            RETURN CODE          EVENT                                   *
'*            ----------------     --------------------------------------  *
'*            EMmoved              Mouse Moved                             *
'*            EMpressedLeft        Mouse left button pressed               *
'*            EMpressedRight       Mouse right button pressed              *
'*            EMpressedCenter      Mouse center button pressed             *
'*            EMreleasedLeft       Mouse left button released              *
'*            EMreleasedRight      Mouse right button released             *
'*            EMreleasedCenter     Mouse center button released            *
'*            EKpressed            Key pressed on keyboard                 *
'*                                                                         *
'***************************************************************************
FUNCTION getEvent% (checkMouse%, keyCode%, mouseX%, mouseY%)

    ' **
    ' ** Clear all events from all buffers
    ' **
    WHILE (INKEY$ <> "")        ' Clear all keypresses from keyboard buffer.
    WEND
    IF (checkMouse%) THEN
        MouseButtonPressInfo LEFTBUTTON, numLeftPresses%, mx%, my%
        MouseButtonPressInfo RIGHTBUTTON, numRightPresses%, mx%, my%
        MouseButtonPressInfo CENTERBUTTON, numCenterPresses%, mx%, my%
        MouseButtonReleaseInfo LEFTBUTTON, numLeftReleases%, mx%, my%
        MouseButtonReleaseInfo RIGHTBUTTON, numRightReleases%, mx%, my%
        MouseButtonReleaseInfo CENTERBUTTON, numCenterReleases%, mx%, my%
        MousePosition oldMouseX%, oldMouseY%
        numLeftPresses% = 0
        numRightPresses% = 0
        numCenterPresses% = 0
        numLeftReleases% = 0
        numRightReleases% = 0
        numCenterReleases% = 0
        mx% = 0
        my% = 0
    END IF

    ' **
    ' ** Initialize event flag
    ' **
    eventOccurred% = FALSE

    ' **
    ' ** Sit in a loop waiting for an event.  If one occurs, set return value,
    ' ** fill in OUT parameters, and get outta here.
    ' **
    WHILE (eventOccurred% = FALSE)

        ' **
        ' ** If OK to do so, check mouse for events.
        ' **
        IF (checkMouse%) THEN

            ' **
            ' ** First, see if mouse has moved.
            ' **
            MousePosition mx%, my%
            IF (mx% <> oldMouseX%) OR (my% <> oldMouseY%) THEN
                mouseX% = (mx% \ 8) + 1
                mouseY% = (my% \ 8) + 1
                returnValue% = EMmoved
                eventOccurred% = TRUE
            END IF

            ' **
            ' ** If no event so far, check to see if mouse left button was pressed.
            ' **
            IF (eventOccurred% = FALSE) THEN
                MouseButtonPressInfo LEFTBUTTON, numLeftPresses%, mx%, my%
                IF (numLeftPresses% <> 0) THEN
                    mouseX% = (mx% \ 8) + 1
                    mouseY% = (my% \ 8) + 1
                    returnValue% = EMpressedLeft
                    eventOccurred% = TRUE
                END IF
            END IF

            ' **
            ' ** If no event so far, check to see if mouse right button was pressed.
            ' **
            IF (eventOccurred% = FALSE) THEN
                MouseButtonPressInfo RIGHTBUTTON, numRightPresses%, mx%, my%
                IF (numRightPresses% <> 0) THEN
                    mouseX% = (mx% \ 8) + 1
                    mouseY% = (my% \ 8) + 1
                    returnValue% = EMpressedRight
                    eventOccurred% = TRUE
                END IF
            END IF

            ' **
            ' ** If no event so far, check to see if mouse left button was
            ' ** released.
            ' **
            IF (eventOccurred% = FALSE) THEN
                MouseButtonReleaseInfo LEFTBUTTON, numLeftReleases%, mx%, my%
                IF (numLeftReleases% <> 0) THEN
                    mouseX% = (mx% \ 8) + 1
                    mouseY% = (my% \ 8) + 1
                    returnValue% = EMreleasedLeft
                    eventOccurred% = TRUE
                END IF
            END IF

            ' **
            ' ** If no event so far, check to see if mouse right button was
            ' ** released.
            ' **
            IF (eventOccurred% = FALSE) THEN
                MouseButtonReleaseInfo RIGHTBUTTON, numRightReleases%, mx%, my%
                IF (numRightReleases% <> 0) THEN
                    mouseX% = (mx% \ 8) + 1
                    mouseY% = (my% \ 8) + 1
                    returnValue% = EMreleasedRight
                    eventOccurred% = TRUE
                END IF
            END IF
        END IF

        ' **
        ' ** If no event so far, check the keyboard for press.
        ' **
        IF (eventOccurred% = FALSE) THEN

            key$ = INKEY$

            IF (key$ <> "") THEN    ' If key was hit then fill in keyCode.
                IF (MID$(key$, 1, 1) = CHR$(0)) THEN
                    keyCode% = CVI(LEFT$(key$ + "  ", 2))
                ELSE
                    keyCode% = ASC(key$)
                END IF
                returnValue% = EKpressed
                eventOccurred% = TRUE
            END IF

        END IF  ' ** No event has occurred **

    WEND

    getEvent% = returnValue%

END FUNCTION

SUB PressButton (buttonType%, x1%, y1%, x2%, y2%, fg%, bg%, txt$, buttonStyle%)

    ' ────────────────────────────────────────────────────────────────────────
    '  This routine simulates the actual visual pressing of a screen button.
    '  If the button is 3D, it "presses" the button by reversing the shading,
    '  thus causing it to appear depressed into the screen instead of raised
    '  from it.  This routine assumes the mouse is being used to activate the
    '  the button.  It will wait until the mouse button is released before
    '  exiting and thus once again raising the button.  The whole effect is
    '  that the user clicks the button with the mouse, it stays depressed
    '  until they let go of it (the mouse button).
    ' ────────────────────────────────────────────────────────────────────────

    ' ────────────────────────────────────────────────────────────────────────
    '  Hide the mouse cursor while we draw on the screen.
    ' ────────────────────────────────────────────────────────────────────────
    MouseHide

    ' ────────────────────────────────────────────────────────────────────────
    '  Draw in a depressed rendition of the button.
    ' ────────────────────────────────────────────────────────────────────────
    PressedButton buttonType%, x1%, y1%, x2%, y2%, fg%, bg%, txt$, buttonStyle%

    ' ────────────────────────────────────────────────────────────────────────
    '  Now show the mouse and wait until we get a button release event.
    ' ────────────────────────────────────────────────────────────────────────
    MouseShow
    MouseButtonReleaseInfo LEFTBUTTON, numReleases%, x%, y%
    numReleases% = 0
    WHILE (numReleases% = 0)
        MouseButtonReleaseInfo LEFTBUTTON, numReleases%, x%, y%
    WEND

    ' ────────────────────────────────────────────────────────────────────────
    '  Now that they've let go of the button, redisplay it in its normal,
    '  raised position.
    ' ────────────────────────────────────────────────────────────────────────
    MouseHide
    DrawButton buttonType%, x1%, y1%, x2%, y2%, fg%, bg%, txt$, buttonStyle%
    MouseShow

END SUB

SUB PressedButton (buttonType%, x1%, y1%, x2%, y2%, fg%, bg%, txt$, buttonStyle%)

    ' ────────────────────────────────────────────────────────────────────────
    '  This routine draws a button on the screen with a text label inside it.
    '  The buttonType% is either SINGLEBORDER or DOUBLEORDER, and the button-
    '  Style%  is either STYLE3D or STYLE2D.  All these constants are defined
    '  in QBSCR.INC.  It will appear to be depressed into the screen.
    ' ────────────────────────────────────────────────────────────────────────

    ' ────────────────────────────────────────────────────────────────────────
    '  Use the DepressedBox routine to draw the basic button border.
    ' ────────────────────────────────────────────────────────────────────────
    DepressedBox buttonType%, x1%, y1%, x2%, y2%, fg%, bg%, buttonStyle%

    ' ────────────────────────────────────────────────────────────────────────
    '  Add the button title centered between the sides of the button.
    ' ────────────────────────────────────────────────────────────────────────
    LOCATE y1% + 1, (((x2% - x1%) - LEN(txt$)) \ 2) + x1% + 1, 0
    COLOR fg%, bg%
    PRINT txt$

END SUB

SUB RaisedBox (boxType%, x1%, y1%, x2%, y2%, fg%, bg%, buttonStyle%)

    ' ────────────────────────────────────────────────────────────────────────
    '  This function displays a 3D box that appears to be raised from the
    '  screen. The boxType% parameter is either SINGLEBORDER or DOUBLEBORDER,
    '  both of which are defined in QBSCR.INC.  The buttonStyle% parameter is
    '  either STYLE3D or STYLE2D, both of which are defined in QBSCR.INC. The
    '  button style STYLE3D is used for color displays or 3D interfaces,
    '  while STYLE2D is used for monochrome or non-3D interfaces.
    ' ────────────────────────────────────────────────────────────────────────

    ' ────────────────────────────────────────────────────────────────────────
    '  Define the box drawing characters based on the boxType%.
    ' ────────────────────────────────────────────────────────────────────────
    IF boxType% = SINGLEBORDER THEN
        ulc$ = CHR$(218)
        urc$ = CHR$(191)
        ver$ = CHR$(179)
        hor$ = CHR$(196)
        llc$ = CHR$(192)
        lrc$ = CHR$(217)
    END IF
    IF boxType% = DOUBLEBORDER THEN
        ulc$ = CHR$(201)
        urc$ = CHR$(187)
        ver$ = CHR$(186)
        hor$ = CHR$(205)
        llc$ = CHR$(200)
        lrc$ = CHR$(188)
    END IF

    ' ────────────────────────────────────────────────────────────────────────
    '  If buttonStyle% is STYLE2D, draw a simple box.
    ' ────────────────────────────────────────────────────────────────────────
    IF (buttonStyle% = STYLE2D) THEN
        COLOR fg%, bg%
        LOCATE y1%, x1%, 0: PRINT ulc$; STRING$(x2% - x1% - 1, hor$); urc$;
        FOR i% = y1% + 1 TO y2% - 1
            LOCATE i%, x1%, 0: PRINT ver$;
            LOCATE i%, x2%, 0: PRINT ver$;
        NEXT i%
        LOCATE y2%, x1%, 0: PRINT llc$; STRING$(x2% - x1% - 1, hor$); lrc$;
        EXIT SUB
    END IF

    ' ────────────────────────────────────────────────────────────────────────
    '  The rest of the code is dedicated to drawing a 3D shaded box.  The
    '  top and left sides are drawn in a white foreground, and the bottom and
    '  right sides are drawn in a black foreground.  This gives the appearance
    '  of a shaded box that is raised from the screen.
    ' ────────────────────────────────────────────────────────────────────────
    COLOR 15, bg%                        ' Draw the top of the box.
    LOCATE y1%, x1%, 0: PRINT ulc$;
    PRINT STRING$(x2% - x1% - 1, hor$);
    COLOR 0, bg%
    PRINT urc$;

    FOR i% = y1% + 1 TO y2% - 1          ' Draw the sides of the box.
        LOCATE i%, x1%, 0: COLOR 15, bg%: PRINT ver$;
        LOCATE i%, x2%, 0: COLOR 0, bg%: PRINT ver$;
    NEXT i%

    COLOR 15, bg%                        ' Draw the bottom of the box.
    LOCATE y2%, x1%, 0: PRINT llc$;
    COLOR 0, bg%
    PRINT STRING$(x2% - x1% - 1, hor$);
    PRINT lrc$;

END SUB