ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng)/ProfitPress-MegaCDROM2.B6I/MAGAZINE/MISC/QBNWS301.ZIP/WINDOW.BAS

BASIC Source File | 1992-03-19 | 7.4 KB | 216 lines

 ' Shadowed window routines by Mark H Butler placed into the public domain
 ' on February 28, 1992 (bye bye babies). I would appreciate any feedback
 ' on these routines and if you improve on them I'd kinda like to know what
 ' you did so I can benefit by the improvements to. If that's a deal then
 ' enjoy the routines... there all yours now.

 DECLARE SUB Drawbox (UpRow%, LtCol%, LoRow%, RtCol%)
 DECLARE SUB Shadow (UpRow%, LtCol%, LoRow%, RtCol%)
 DECLARE SUB Explode (UpRow%, LtCol%, LoRow%, RtCol%)
 DECLARE SUB Expand (UpRow%, LtCol%, LoRow%, RtCol%)
 DECLARE SUB ScreenClear (LineColor%)
 DECLARE SUB Delay (ticks!)

 ' These first lines of code are included to demo the
 ' exploding and expanding window routines.
 ' We'll fill the sceen with a bunch of crap so our windows
 ' will have a backdrop you can see their shadows against.

    LOCATE , , 0
    COLOR 14, 1
    CLS
    FOR I = 1 TO 13
        FOR ch = 33 TO 178
            PRINT CHR$(ch);
        NEXT ch
    NEXT I

    COLOR 4, 7
    Explode 5, 15, 15, 65

    COLOR 0
    LOCATE 9, 27
    PRINT "This 'exploding' window was"
    LOCATE 10, 25
    PRINT "written entirely in QuickBASIC! "
    LOCATE 12, 21
    PRINT "(press any key for the 'Expand' routine)"
    SLEEP

    COLOR 0, 3
    Expand 2, 5, 22, 75

    COLOR 4
    LOCATE 8, 12
    PRINT "This is the 'Expand' routine. Like 'Explode' it calls"
    LOCATE 9, 12
    PRINT "the 'Drawbox' routine. It expands to it's full horizontal"
    LOCATE 10, 12
    PRINT "width  *before*  it begins to expand vertically though."
    LOCATE 13, 12
    PRINT "(press any key for some semi-fancy screen clearing)"
    SLEEP
    ScreenClear 3

 SUB Drawbox (UpRow%, LtCol%, LoRow%, RtCol%) STATIC
 ' This routine draws a double line box to the dimensions set
 ' in UpRow%, LtCol%, LoRow% and RtCol%. If you want a single line box
 ' just change the ascii chars, e.g. change CHR$(205) to CHR$(196) etc.
 '
    Wide% = (RtCol% - LtCol%) - 1
    LOCATE UpRow%, LtCol%
    PRINT CHR$(201); STRING$(Wide%, CHR$(205)); CHR$(187);
    FOR I% = UpRow% + 1 TO LoRow% - 1
        LOCATE I%, LtCol%
        PRINT CHR$(186); SPACE$(Wide%); CHR$(186);
    NEXT I%
    LOCATE LoRow%, LtCol%
    PRINT CHR$(200); STRING$(Wide%, CHR$(205)); CHR$(188);
 END SUB

 SUB Expand (UpRow%, LtCol%, LoRow%, RtCol%) STATIC
 ' This routine will "expand" the window onto the screen calling on
 ' DRAWBOX to draw sucessively wider boxes until it hits the width
 ' dimensions. Then it will expand to meet the vertical dimensions.
 '
    RowCenter% = ((LoRow% - UpRow%) / 2) + UpRow%
    ColCenter% = ((RtCol% - LtCol%) / 2) + LtCol%
    UprRow% = RowCenter%: LeftCol% = ColCenter%
    LwrRow% = RowCenter%: RghtCol% = ColCenter%
    DO
        LeftCol% = LeftCol% - 1
        RghtCol% = RghtCol% + 1
        IF LeftCol% < LtCol% THEN LeftCol% = LtCol%
        IF RghtCol% > RtCol% THEN RghtCol% = RtCol%
        Drawbox UprRow%, LeftCol%, LwrRow%, RghtCol%
        IF LeftCol% = LtCol% AND RghtCol% = RtCol% THEN EXIT DO
    LOOP
    DO
        UprRow% = UprRow% - 1
        LwrRow% = LwrRow% + 1
        IF UprRow% < UpRow% THEN UprRow% = UpRow%
        IF LwrRow% >= LoRow% THEN LwrRow% = LoRow%
        Drawbox UprRow%, LeftCol%, LwrRow%, RghtCol%
        IF UprRow% = UpRow% AND LwrRow% = LoRow% THEN EXIT DO
    LOOP
    Shadow UpRow%, LtCol%, LoRow%, RtCol%
 END SUB

 SUB Explode (UpRow%, LtCol%, LoRow%, RtCol%) STATIC
 ' This routine will "explode" the window onto the screen calling on
 ' DRAWBOX to draw sucessively larger boxes until it hits the limits
 ' set in UpRow%, LtCol%, LoRow% and RtCol%. The first few lines determine
 ' where the approximate center of the box begins even if the window is
 ' to be located off-center with respect to the screen.
 '
    RowCenter% = ((LoRow% - UpRow%) / 2) + UpRow%
    ColCenter% = ((RtCol% - LtCol%) / 2) + LtCol%
    UprRow% = RowCenter%: LeftCol% = ColCenter%
    LwrRow% = RowCenter%: RghtCol% = ColCenter%
    DO
        UprRow% = UprRow% - 1
        LeftCol% = LeftCol% - 3
        LwrRow% = LwrRow% + 1
        RghtCol% = RghtCol% + 3
        IF UprRow% < UpRow% THEN UprRow% = UpRow%
        IF LeftCol% < LtCol% THEN LeftCol% = LtCol%
        IF LwrRow% > LoRow% THEN LwrRow% = LoRow%
        IF RghtCol% > RtCol% THEN RghtCol% = RtCol%
        Drawbox UprRow%, LeftCol%, LwrRow%, RghtCol%
        IF UprRow% = UpRow% AND LeftCol% = LtCol% THEN
            IF LwrRow% = LoRow% AND RghtCol% = RtCol% THEN
                EXIT DO
            END IF
        END IF
    LOOP
    Shadow UpRow%, LtCol%, LoRow%, RtCol%   '*** now give it a shadow ****
 END SUB
 SUB ScreenClear (LineColor%) STATIC
 'This routine will do a little fancy screen clearing by simulating
 'an old style 1950s TV set being shut off. Screen shrinks to a single
 'horizontal line then disappears to a shrinking dot and is gone.
 'I wrote it for 80x25 text mode so if your displaying more screen lines
 'than 25 you'll have to play with it to get it to erase them all.
 '
    LOCATE , , 0
    DIM Lines$(1 TO 23)
    Lines$(1) = STRING$(80, CHR$(196))
    Sp% = 2
    Length% = 76
    FOR I% = 2 TO 21
        Lines$(I%) = SPACE$(Sp%) + STRING$(Length%, CHR$(196)) + SPACE$(2)
        Sp% = Sp% + 2
        Length% = Length% - 4
    NEXT I%
    Lines$(22) = SPACE$(39) + CHR$(254) + SPACE$(2)

    Lines$(23) = SPACE$(39) + "." + SPACE$(2)
    COLOR 0, 0
    x% = 1
    y% = 25
    FOR I% = 1 TO 12
        LOCATE y%, 1
        PRINT STRING$(80, CHR$(32));
        LOCATE x%, 1
        PRINT STRING$(80, CHR$(32));
        Delay .04
        x% = x% + 1
        y% = y% - 1
    NEXT I%
    COLOR LineColor%, 0
    FOR I% = 1 TO 23
        LOCATE 13, 1
        PRINT Lines$(I%);
        Delay .04
    NEXT I%
    COLOR 7
    LOCATE , , 1, 6, 7
    CLS
 END SUB

 SUB Shadow (UpRow%, LtCol%, LoRow%, RtCol%) STATIC
 ' This routine creates a transparent shadow along the right side
 ' and bottom edge of the box. Note: Special thanks to John Strong
 ' for his very helpful tips on what to POKE and where.
 '
    DEF SEG = &H40
    mono% = PEEK(&H10)
    IF (mono% AND 48) = 48 THEN
        EXIT SUB            '*** Forget the shadow if it's monochrome.
    ELSE
        DEF SEG = &HB800
    END IF

 '****** find out what the screen attributes already are ****

    attr% = SCREEN(LoRow% + 1, RtCol% + 1, -1)  ' Get the attribute.
    attr% = attr% AND 15                     ' Calculate forground.
    attr% = attr% - 8                        ' Remove bright.
    IF attr% < 1 THEN attr% = 8              ' In case color wasn't bright.

 '****** use the given box dimensions to POKE a ***********
 '****** shadow on the right side and bottom edge *********

    FOR row% = UpRow% + 1 TO LoRow% + 1       '***** right edge locations.
        FOR Col% = RtCol% + 1 TO RtCol% + 2   '***** make it 2 chars Wide.
            offset% = (row% - 1) * 160 + (Col% - 1) * 2 + 1
            POKE offset%, attr%
        NEXT
    NEXT
    row% = LoRow% + 1                        '***** now POKE along the
    FOR Col% = LtCol% + 2 TO RtCol% + 2      '***** bottom edge
        offset% = (row% - 1) * 160 + (Col% - 1) * 2 + 1
        POKE offset%, attr%
    NEXT
    DEF SEG
 END SUB

 SUB Delay (ticks!)
 'The next sub is just a little delay that ScreenClear needs
 '
    begintime! = TIMER
    DO
    LOOP UNTIL TIMER - begintime! > ticks!
 END SUB