home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Power-Programmierung
/
CD1.mdf
/
basic
/
library
/
pb
/
library4
/
boxes-u.bas
< prev
next >
Wrap
BASIC Source File
|
1990-08-21
|
8KB
|
226 lines
'==============================================================================
' THE FOURTH UNIT -- BOXES-U.BAS
'==============================================================================
' -- 2-18-90
$COMPILE UNIT
$ERROR ALL OFF
DEFINT A-Z
EXTERNAL RD$, ColorDisplay, NeedDCon
EXTERNAL BoxColor, FldColor, WinColor, CursorTop, CursorBottom, Ln, Col
EXTERNAL PressAKeyBeep$, OopsBeep$, TinyBeep$
EXTERNAL LocalAreaCode$, Record%
EXTERNAL BXScreenSaved, PMScreenSaved
EXTERNAL FieldName$(), FieldMask$(), FL(), FC(), Fields%
SUB BOXMESSAGE(CornerLin, CornerCol, Margin) PUBLIC
' ==== Boxes and displays your message.
' Top L. corner will be at the designated coordinates,
' but errors are trapped so box will stay on the
' screen regardless. The message line should appear
' in your code as DATA statements, terminated by
' "END". A RESTORE statement is needed, of course.
' See HBDEMO.BAS for examples & comments.
LOCAL I$(), Maxx, Items%, D$
LOCATE ,,0 ' extinguish the cursor
BReadlines:
DIM I$(23) ' each I$ is a msg line; # of lines is Items%
READ D$
WHILE D$ <> "END" AND Items% < 23 ' (from data list)
INCR Items% ' count 1 item
I$(Items%) = D$ ' plug the data into array
IF LEN(D$) > Maxx THEN Maxx = LEN(D$) ' Maxx = length of longest I$()
READ D$ ' ... and repeat.
WEND
CALL BOXMESSAGE2 (CornerLin, CornerCol, Margin, I$(), Items%, Maxx)
END SUB REM BOXMESSAGE
'______________________________________________________________________________
SUB BOXMESSAGE2 (CornerLin, CornerCol, Margin, I$(1), Items%, Maxx) PUBLIC
' Use this call if you wish to set text lines -- I$() -- at runtime instead
' of using DATA statements ...
LOCAL Wid, Height, I, P, Y, Z, F, Bar$
BSetVars:
Wid = Maxx + 4 + 4*Margin ' compute box size --
Height = Items%+2 + 2*Margin
IF Wid > 80 THEN Wid = 80
IF Height > 24 THEN Height = 24
IF CornerCol = 0 THEN CornerCol = 41 - Wid \ 2
CornerCol = ABS(CornerCol): IF CornerCol > 80-Wid THEN CornerCol = 80-Wid
IF CornerLin = 0 THEN CornerLin = 13 - Height \ 2
CornerLin = ABS(CornerLin):IF CornerLin > 25-Height THEN CornerLin = 25-Height
' error traps keep box on screen
Bar$ = "\"+SPACE$(Wid-4)+"\" ' set a line mask
BPrint:
LOCATE CornerLin, CornerCol
I = BoxColor MOD 16
P = BoxColor \ 16 ' set local variables for colors and
IF P > 7 THEN
DECR P, 8: F = 16 ' if box is to flash, set I as nonflashing
BoxColor = BoxColor - %Flash
END IF
COLOR I + F , P
' print top bar
PRINT CHR$(201);: PRINT STRING$((Wid-2),205);: PRINT CHR$(187);
Z = CornerLin+1
IF Margin > 0 THEN
FOR Y = 1 TO Margin
LOCATE Z ,CornerCol
COLOR I + F , P : PRINT CHR$(186);: COLOR I , P
PRINT USING Bar$;" ";
COLOR I + F , P : PRINT CHR$(186);: COLOR I , P
INCR Z
NEXT
END IF
'
' print message lines
FOR Y = 1 TO Items%
LOCATE Z,CornerCol
COLOR I + F , P : PRINT CHR$(186);: COLOR I , P ' print border char.
PRINT USING BAR$;SPACE$(2*Margin+(Maxx-Len(I$(Y)))/2+.9)+I$(Y);
' count off enough spaces to center the characters then print 'em ...
COLOR I + F , P : PRINT CHR$(186); ' and print right hand border.
INCR Z
NEXT
IF Margin THEN ' print appropriate # of blank lines for margin
FOR Y = 1 TO Margin
LOCATE Z,CornerCol
COLOR I + F , P : PRINT CHR$(186);: COLOR I , P
PRINT USING Bar$;" ";
INCR Z
COLOR I + F , P : PRINT CHR$(186);
NEXT
END IF
' print bottom bar
LOCATE Z,CornerCol,1:PRINT CHR$(200);:PRINT STRING$((Wid-2),205);
PRINT CHR$(188);
COLOR I , P
END SUB REM BOXMESSAGE2
' =============================================================================
SUB POPWINDOW PUBLIC ' print a data entry window ...
' and set up its lookup table
LOCAL X, Y, Z, Title$, CornerCol, CornerLin, Prompt$, Ht, A$
COLOR WinColor MOD 16, WinColor \ 16
READ A$: Wid = VAL(A$)
READ A$: CornerLin = VAL(A$)
READ A$: CornerCol = VAL(A$)
READ A$: Ht = VAL(A$)
' print top of window ...
LOCATE CornerLin, CornerCol: PRINT CHR$(201);
PRINT STRING$((Wid-2),205);: PRINT CHR$(187);
FOR Z = CornerLin+1 TO CornerLin+Ht-2 ' sides ...
LOCATE Z, CornerCol: PRINT CHR$(186);SPACE$(Wid-2); CHR$(186);
NEXT Z
' ... print bottom bar.
LOCATE Z, CornerCol:PRINT CHR$(200);
PRINT STRING$((Wid-2),205);: PRINT CHR$(188);
READ Prompt$, X, Y ' place prompts in window (you hope ...)
DO
LOCATE X, Y: PRINT Prompt$
READ Prompt$: IF Prompt$ <> "END" THEN READ X, Y
LOOP UNTIL Prompt$ = "END"
COLOR FldColor MOD 16, FldColor \ 16
Z=1
READ FieldName$(Z),FieldMask$(Z),FL(Z),FC(Z) ' create the table for
' this record data window
DO
LOCATE FL(Z),FC(Z)
PRINT SPACE$ (LEN(FieldMask$(Z))) ' print a blank field ...
INCR Z
READ FieldName$(Z)
IF FieldName$(Z) <> "END" THEN READ FieldMask$(Z), FL(Z), FC(Z)
LOOP UNTIL FieldName$(Z) = "END"
Fields% = Z-1
END SUB
' ----------------------------------------------------------------------------
SUB PWSetUp (Fld$,Z) PUBLIC ' sets up to ENTER a record field at the right
' location in a pop-up data record window using the
' lookup table (FieldName$() etc.). When a match is
' found the cursor is placed. The subscript # used
' is returned as the parameter Z.
Z = 1
DO UNTIL FieldName$(Z) = Fld$ 'find fld name in table
INCR Z
IF Z > Fields% THEN
BEEP
LOCATE 25,1
PRINT " PWSetUp error: window for "+Fld$+" not open !!! "
DO: LOOP UNTIL INKEY$ <> ""
END 1
END IF
LOOP
LOCATE FL(Z), FC(Z)
END SUB REM PWSetUp
' =========================================================================
SUB QBOX (L, C, Lines%, Message$, AnsFldLength) PUBLIC
LOCAL I$(), AFCol, AFLin, Items, Maxx
DIM I$(4)
IF Lines% > 1 THEN
IF C = %Center THEN C = 80 - (LEN (Message$) - AnsFldength - 4) / 2
I$(1) = Message$
Items% = 3
I$(2) = " "
I$(3) = " "
AFCol = C + 2
IF LEN (Message$) > AnsFldLength THEN _
INCR AFCol, (LEN(Message$)-AnsFldLength)/2
AFLin = L+3
Maxx = LEN(Message$)
IF AnsFldLength > Maxx THEN Maxx = AnsFldLength
ELSE
IF C = %Center THEN C = (76 - LEN (Message$)) / 2
I$(1) = Message$+SPACE$(AnsFldLength)
Items% = 1
AFCol = C + 2 + LEN (Message$) ' or 6
AFLin = L+1
Maxx = LEN(Message$)+AnsFldLength
END IF
CALL BOXMESSAGE2 (L,C,0,I$(),Items%,Maxx)
LOCATE AFLin,AFCol,1
END SUB
' with L & C set correctly for and ENTER call -- Wowee !!!