home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Boston 2
/
boston-2.iso
/
DOS
/
PROGRAM
/
BASIC
/
POWBASIC
/
LIBRARY2
/
PW200.ZIP
/
PD200.BAS
next >
Wrap
BASIC Source File
|
1990-03-09
|
17KB
|
518 lines
' PW200 VIDEO, WINDOW AND MENU SUBROUTINES AND FUNCTIONS
' POWERBASIC VERSION 2.0 DEMONSTRATION PROGRAM
' COPYRIGHT (C) 1990, RICHARD D. FOTHERGILL ALL RIGHTS RESERVED
$COMPILE EXE
$LIB ALL-
$ERROR ALL-
$INCLUDE "PW200.INC"
CALL Openwin(1,1,25,80,attr(0,7),attr(0,7),0,0,0,0)
CALL Fakewin(2,1,23,80,attr(7,1),attr(7,1),1,0,0,0)
CALL Openwin(5,20,11,40,attr(0,7),attr(1,7),2,0,0,0)
CALL Printcwin(2,"PW200")
SELECT CASE curdisplay%
CASE 0 : msg$ = "MONO"
CASE 1 : msg$ = "CGA"
CASE 2 : msg$ = "EGA"
CASE 3 : msg$ = "MCGA"
CASE 4 : msg$ = "VGA"
END SELECT
msg1$ = STR$(curvideo%)
msg$ = msg$ + " monitor in video mode "+msg1$
CALL Printcwin(3,msg$)
IF mousehere THEN msg$ = "Mouse present and active." ELSE msg$ = "No mouse present"
CALL Printcwin(4,msg$)
CALL Printcwin(5,"Copyright (C) 1990")
CALL Printcwin(6,"by Richard D. Fothergill")
CALL Printcwin(7,"All Rights Reserved")
x = 0
WHILE NOT INSTAT AND (x < 32000)
INCR x
WEND
CALL Closewin
IF INKEY$ <> "" THEN
a$ = INKEY$
a$ = CHR$(0)
END IF
done = 0
CALL Initmenus
CALL Sprint(25,1," Use arrow keys to change selection - Return to select ",attr(0,3))
WHILE NOT done
CALL Makehmenu(mitem$(),subitem$,mitemcount,mcurntpos,mstartpos,mhlattr,mflattr,mflon,mmenuspaces,mbarloc)
SELECT CASE mcurntpos
CASE 1 : CALL Fdemo
CASE 2 : CALL Tdemo
CASE 3 : CALL Sdemo
CASE 4 : CALL Edemo
CASE ELSE
CALL Closewin
CLS
CALL Openwin(9,16,8,52,attr(0,7),attr(1,7),2,0,0,0)
CALL Printcwin(3," P W ")
CALL Printcwin(4,"2 0 0")
DELAY(3)
CALL Closewin
done = -1
END SELECT
WEND
END
SUB Initmenus
SHARED mitem$(),subitem$,mitemcount,mcurntpos,mstartpos,mhlattr,mflattr,mflon,mmenuspaces,mbarloc
SHARED sitem$(),sliveitem$,sitemcount,scurntpos,sstartpos,shlattr,sflattr,snoattr,sbartype,sflon
SHARED eitem$(),eliveitem$,eitemcount,ecurntpos,estartpos,ehlattr,eflattr,enoattr,ebartype,eflon IF curvideo = 7 THEN menunoattr = attr(0,0) ELSE menunoattr = attr(8,7)
mcurntpos = 0
mstartpos = 1
DIM mitem$(5)
mitem$(1) = "Frames"
mitem$(2) = "Titles"
mitem$(3) = "Shadows"
mitem$(4) = "Demos"
mitem$(5) = "Quit"
mitemcount = 5
mhlattr = attr(7,0)
mflattr = attr(15,7)
mflon = -1
mmenuspaces = 8
mbarloc = 0
subitem$ ="001110"
sliveitem$ = "11011011"
scurntpos = 0
sstartpos = 1
DIM sitem$(8)
sitem$(1) = "Flat ( 0)"
sitem$(2) = "Reattribute (1, 2)"
sitem$(3) = "Solid (3, 4)"
sitem$(4) = "Light Hatch (5, 6)"
sitem$(5) = "Medium Hatch (7, 8)"
sitem$(6) = "Heavy Hatch (9,10)"
sitem$(7) = "Activate Items 3,6 "
sitem$(8) = "Deact. Items 3,6 "
sitemcount = 8
shlattr = attr(7,0)
sflattr = attr(15,7)
snoattr = menunoattr
sbartype = 1
sflon = -1
eliveitem$ = "11111"
ecurntpos = 0
estartpos = 1
DIM eitem$(5)
eitem$(1) = "Pop Windows "
eitem$(2) = "Zoom Windows "
eitem$(3) = "File / List Window"
eitem$(4) = "DOS Utilities "
eitem$(5) = "Field Input "
eitemcount = 5
ehlattr = attr(7,0)
eflattr = attr(15,7)
enoattr = menunoattr
ebartype = 1
eflon = -1
END SUB
SUB Continue
CALL Sprintc(25,1,80," Press any key to continue... ",attr(15,3))
CALL Getkey(a1$,a2$)
CALL Sprintc(25,1,80,"Use arrow keys to change selection - Return to select",attr(0,3))
END SUB
SUB Fdemo
CALL Openwin(5,15,6,15,attr(15,2),attr(15,2),0,0,1,0)
CALL Titlewin(2,attr(14,2),"[ Style 0 ]")
CALL Openwin(5,34,6,15,attr(15,5),attr(15,5),1,8,1,0)
CALL Titlewin(2,attr(14,5),"[ Style 1 ]")
CALL Openwin(5,53,6,15,attr(15,3),attr(15,3),2,8,1,0)
CALL Titlewin(2,attr(14,3),"[ Style 2 ]")
CALL Openwin(8,5,6,15,attr(15,4),attr(15,4),3,8,1,0)
CALL Titlewin(2,attr(14,4),"[ Style 3 ]")
CALL Openwin(8,24,6,15,attr(15,3),attr(15,3),4,8,1,0)
CALL Titlewin(2,attr(14,3),"[ Style 4 ]")
CALL Openwin(8,43,6,15,attr(15,6),attr(15,6),5,8,1,0)
CALL Titlewin(2,attr(14,6),"[ Style 5 ]")
CALL Openwin(8,62,6,15,attr(15,5),attr(15,5),6,8,1,0)
CALL Titlewin(2,attr(14,5),"[ Style 6 ]")
CALL Openwin(11,15,6,15,attr(15,2),attr(15,2),7,8,1,0)
CALL Titlewin(2,attr(14,2),"[ Style 7 ]")
CALL Openwin(11,34,6,15,attr(15,7),attr(15,7),8,8,1,0)
CALL Titlewin(2,attr(14,7),"[ Style 8 ]")
CALL Openwin(11,53,6,15,attr(15,4),attr(15,4),9,8,1,0)
CALL Titlewin(2,attr(14,4),"[ Style 9 ]")
CALL Openwin(14,5,6,15,attr(15,7),attr(15,7),10,8,1,0)
CALL Titlewin(2,attr(14,7),"[ Style 10]")
CALL Openwin(14,24,6,15,attr(15,6),attr(15,6),11,8,1,0)
CALL Titlewin(2,attr(14,6),"[ Style 11]")
CALL Openwin(14,43,6,15,attr(15,5),attr(15,5),12,8,1,0)
CALL Titlewin(2,attr(14,5),"[ Style 12]")
CALL Openwin(14,62,6,15,attr(15,2),attr(15,2),13,8,1,0)
CALL Titlewin(2,attr(14,2),"[ Style 13]")
CALL Openwin(17,15,6,15,attr(15,3),attr(15,3),14,8,1,0)
CALL Titlewin(2,attr(14,3),"[ Style 14]")
CALL Openwin(17,34,6,15,attr(15,2),attr(15,2),15,8,1,0)
CALL Titlewin(2,attr(14,2),"[ Style 15]")
CALL Openwin(17,53,6,15,attr(15,7),attr(15,7),16,8,1,0)
CALL Titlewin(2,attr(14,7),"[ Style 16]")
CALL Continue
FOR x = 1 TO 17
CALL Closewin
NEXT
END SUB
SUB Tdemo
CALL Openwin(8,8,10,68,attr(15,5),attr(15,5),2,0,1,0)
CALL Printcwin(3,"Titles may be placed in any of six different locations")
CALL Printcwin(4,"and in any color attribute!")
FOR x=1 TO 6
msg$ = STR$(x)
msg$ = "[ LOCATION "+msg$+" ]"
CALL Titlewin(x,attr(9+x,5),msg$)
DELAY(1)
NEXT
CALL Continue
CALL Closewin
END SUB
SUB Sdemo
SHARED sitem$(),sliveitem$,sitemcount,scurntpos,sstartpos,shlattr,sflattr,snoattr,sbartype,sflon
CALL Openwin(2,32,10,23,attr(0,7),attr(0,7),1,8,1,0)
done = 0
WHILE NOT done
CALL Makevmenu(sitem$(),sliveitem$,sitemcount,scurntpos,sstartpos,shlattr,sflattr,snoattr,sbartype,sflon)
SELECT CASE scurntpos
CASE 1
CALL Openwin(10,4,7,74,attr(15,5),attr(15,5),2,0,0,0)
CALL Titlewin(2,attr(15,5)," FLAT ")
CALL Openwin(11,8,10,30,attr(15,3),attr(0,3),1,0,0,0)
CALL Openwin(11,43,10,30,attr(15,7),attr(1,7),1,0,0,0)
CALL Continue
CALL Closewin
CALL Closewin
CALL Closewin
CASE 2
CALL Openwin(10,4,7,74,attr(15,5),attr(15,5),2,0,0,0)
CALL Titlewin(2,attr(15,5)," REATTRIBUTE ")
CALL Openwin(11,8,10,30,attr(15,3),attr(0,3),2,8,1,0)
CALL Printcwin(7,"Left Shadow")
DELAY(2)
CALL Openwin(11,43,10,30,attr(15,7),attr(1,7),2,8,2,0)
CALL Printcwin(7,"Right Shadow")
CALL Continue
CALL Closewin
CALL Closewin
CALL Closewin
CASE 3
CALL Openwin(10,4,7,74,attr(15,5),attr(15,5),2,0,0,0)
CALL Titlewin(2,attr(15,5)," SOLID ")
CALL Openwin(11,8,10,30,attr(15,3),attr(0,3),2,0,3,0)
CALL Printcwin(7,"Left Shadow")
DELAY(2)
CALL Openwin(11,43,10,30,attr(15,7),attr(1,7),2,0,4,0)
CALL Printcwin(7,"Right Shadow")
CALL Continue
CALL Closewin
CALL Closewin
CALL Closewin
CASE 4
CALL Openwin(10,4,7,74,attr(15,5),attr(15,5),2,0,0,0)
CALL Titlewin(2,attr(15,5)," LT. HATCH ")
CALL Openwin(11,8,10,30,attr(15,3),attr(0,3),2,attr(0,7),5,0)
CALL Printcwin(7,"Left Shadow")
DELAY(2)
CALL Openwin(11,43,10,30,attr(15,7),attr(1,7),2,attr(0,7),6,0)
CALL Printcwin(7,"Right Shadow")
CALL Continue
CALL Closewin
CALL Closewin
CALL Closewin
CASE 5
CALL Openwin(10,4,7,74,attr(15,5),attr(15,5),2,0,0,0)
CALL Titlewin(2,attr(15,5)," MED. HATCH ")
CALL Openwin(11,8,10,30,attr(15,3),attr(0,3),2,attr(0,7),7,0)
CALL Printcwin(7,"Left Shadow")
DELAY(2)
CALL Openwin(11,43,10,30,attr(15,7),attr(1,7),2,attr(0,7),8,0)
CALL Printcwin(7,"Right Shadow")
CALL Continue
CALL Closewin
CALL Closewin
CALL Closewin
CASE 6
CALL Openwin(10,4,7,74,attr(15,5),attr(15,5),2,0,0,0)
CALL Titlewin(2,attr(15,5)," HEAVY HATCH ")
CALL Openwin(11,8,10,30,attr(15,3),attr(0,3),2,attr(0,7),9,0)
CALL Printcwin(7,"Left Shadow")
DELAY(2)
CALL Openwin(11,43,10,30,attr(15,7),attr(1,7),2,attr(0,7),10,0)
CALL Printcwin(7,"Right Shadow")
CALL Continue
CALL Closewin
CALL Closewin
CALL Closewin
CASE 7
MID$(sliveitem$,3) = "1"
MID$(sliveitem$,6) = "1"
CASE 8
MID$(sliveitem$,3) = "0"
MID$(sliveitem$,6) = "0"
CASE ELSE
CALL Closewin
done = -1
END SELECT
WEND
done = 0
END SUB
SUB Edemo
SHARED eitem$(),eliveitem$,eitemcount,ecurntpos,estartpos,ehlattr,eflattr,enoattr,ebartype,eflon
CALL Openwin(2,46,7,22,attr(0,7),attr(0,7),1,8,1,0)
done = 0
WHILE NOT done
CALL Makevmenu(eitem$(),eliveitem$,eitemcount,ecurntpos,estartpos,ehlattr,eflattr,enoattr,ebartype,eflon)
SELECT CASE ecurntpos
CASE 1
CALL Openwin(8,8,10,65,attr(15,5),attr(15,5),2,0,1,0)
CALL Printcwin(3,"Windows can be popped")
CALL Printcwin(4,"onto the screen.")
DELAY(2)
CALL Openwin(5,5,10,50,attr(0,2),attr(14,2),2,8,1,0)
DELAY(2)
CALL Openwin(13,15,10,60,attr(1,3),attr(15,3),3,8,1,0)
DELAY(2)
CALL Openwin(7,33,10,45,attr(14,5),attr(14,5),1,8,1,0)
CALL Continue
FOR x = 1 TO 4
CALL Closewin
NEXT
CASE 2
CALL Openwin(8,8,10,65,attr(15,5),attr(15,5),2,0,1,0)
CALL Printcwin(3,"Windows can be zoomed")
CALL Printcwin(4,"onto the screen.")
DELAY(2)
winspeed = 0
CALL Openwin(5,5,10,50,attr(0,2),attr(14,2),2,8,1,1)
DELAY(2)
winspeed = 10000
CALL Openwin(13,15,10,60,attr(1,3),attr(15,3),3,8,1,1)
DELAY(2)
winspeed = 20000
CALL Openwin(7,33,10,45,attr(14,5),attr(14,5),1,8,1,1)
DELAY(2)
winspeed = 30000
CALL Openwin(7,20,12,40,attr(15,4),attr(14,4),2,8,1,1)
CALL Printcwin(5,"HOW ABOUT THAT !!!")
CALL Continue
FOR x = 1 TO 5
CALL Closewin
NEXT
CASE 3
CALL Showfile
CASE 4
CALL Ddemo
CASE 5
CALL Idemo
CASE ELSE
CALL Closewin
done = -1
END SELECT
WEND
done = 0
END SUB
SUB Showfile
dirinfo$ = STRING$(43,CHR$(0))
DIM recarr$(5000)
CALL Openwin(10,20,7,41,attr(0,7),attr(1,7),2,attr(8,0),1,0)
CALL Titlewin(5,attr(1,7),"[ Press Enter for Directory ]")
CALL Printcwin(2,"Enter a Text File Name to Display")
sourcename$ = ""
Capson = -1
CALL Getfield(4,10,sourcename$,"S",20,0,retcode,attr(15,1),attr(0,7))
Capson = 0
CALL Closewin
IF retcode <> 0 THEN
IF sourcename$ = "" THEN
sourcename$ = Makefmenu$("*.*",5,10,17,attr(1,7),attr(1,7),2,attr(8,0),1,0,attr(7,1))
END IF
IF RIGHT$(sourcename$,1)<>"\" THEN
CALL Findfirst(sourcename$+CHR$(0),&H10,dirinfo$,doserror)
IF doserror = 0 THEN
OPEN sourcename$ FOR INPUT AS #1
rec = 1
DO
LINE INPUT #1,recarr$(rec)
IF LEN(recarr$(rec)) > 76 THEN
recarr$(rec + 1) = RIGHT$(recarr$(rec),LEN(recarr$(rec))-76)
recarr$(rec) = LEFT$(recarr$(rec),76)
INCR rec
END IF
INCR rec
LOOP UNTIL EOF(1)
CLOSE #1
CALL Openwin(1,1,25,80,Attr(7,0),Attr(15,1),0,0,0,0)
CALL Titlewin(1,Attr(15,1),"LIST DEMO")
CALL Titlewin(3,Attr(15,1),Falign$(sourcename$))
CALL Makelmenu(recarr$(),rec,pickrec,1,Attr(0,7))
CALL Closewin
ELSE
CALL Openwin(10,20,5,40,Attr(15,4),Attr(15,4),2,Attr(8,0),1,0)
CALL Printcwin(2,"FILE NOT FOUND - PROCEDURE ABORTED!")
CALL Continue
CALL Closewin
END IF
END IF
END IF
ERASE recarr$
END SUB
SUB Ddemo
LOCAL dirinfo$,doserror
dirinfo$ = SPACE$(43)
CALL Openwin(1,1,24,80,attr(7,1),attr(7,1),0,0,0,0)
PRINT
PRINT
PRINT
PRINT " The following is a sampling of the DOS functions available"
PRINT " in PW201. For a better understanding of how to use the"
PRINT " information returned by these functions consult any of the"
PRINT " reference books on DOS interrupts. You must have a good"
PRINT " understanding of DOS interrupts to take full advantage of"
PRINT " these utilities."
CALL Continue
CALL Clearwin
LOCATE 1,1
PRINT " THE DEFAULT DRIVE IS "Curdrive$
PRINT
PRINT " THEN CURRENT DIRECTORY PATH IS "Curdir$
PRINT
PRINT " FILES IN THIS DIRECTORY ARE:"
PRINT
CALL Findfirst("*.*"+CHR$(0),&H20,dirinfo$,doserror)
PRINT Falign$(EXTRACT$(MID$(dirinfo$,31,12),CHR$(0)))" ";
WHILE doserror = 0
CALL Findnext(dirinfo$,doserror)
PRINT Falign$(EXTRACT$(MID$(dirinfo$,31,12),CHR$(0)))" ";
WEND
PRINT
PRINT
PRINT " THE CURRENT DOS VERSION IS "Dosversion$
PRINT USING " CURRENT DISK SIZE ###,###,###";Disksize&(0)
PRINT USING " DISK SPACE AVAILABLE ###,###,###";Diskfree&(0)
PRINT USING " CONV MEMORY SIZE ###,###";Maxmem&
PRINT USING " AVAILABLE MEMORY ###,###";FRE(-1)
CALL Continue
CALL Closewin
END SUB
SUB Idemo
LOCAL wfield,done,info$(),loandata$()
DIM info$(3)
info$(1) = "R0010221092"
info$(2) = "R0020324062"
info$(3) = "I0030426040"
DIM loandata$(3)
CALL Openwin(5,7,14,32,attr(0,3),attr(0,3),2,8,1,0)
CALL Titlewin(2,attr(15,3),"[ Payment Calculator ]")
CALL Titlewin(5,attr(15,3),"[ Esc - Exit ]")
CALL Printwin(2,2,"Principal Amount:")
CALL Printwin(3,2," Interest Rate:")
CALL Printwin(4,2," No. of Payments:")
CALL Printwin(5,2," Payment:")
CALL Printcwin(7, "F1 - Help ")
CALL Printcwin(8, "F2 - Calculate Payment")
CALL Printcwin(9, "F5 - Pop-up Calculator")
done = 0
wfield = 1
WHILE NOT done
IF amount## = 0 THEN loandata$(1) = "" ELSE loandata$(1) = STR$(amount##)
IF rate## = 0 THEN loandata$(2) = "" ELSE loandata$(2) = STR$(rate##)
IF month = 0 THEN loandata$(3) = "" ELSE loandata$(3) = STR$(month)
DO
CALL Getrec(info$(),loandata$(),3,returncode,wfield,-1,attr(3,0),attr(0,3))
LOOP UNTIL INSTR(CHR$(0)+CHR$(59)+CHR$(60)+CHR$(63),CHR$(returncode))
amount## = VAL(loandata$(1))
rate## = VAL(loandata$(2))
month = VAL(loandata$(3))
SELECT CASE returncode
CASE 0 : done = -1
CASE 59 : CALL Help.Message(wfield)
CASE 60 : CALL Compute.Payment(amount##,rate##,month)
CASE 63 : CALL Calculator(5,49,attr(15,5),1)
END SELECT
WEND
CALL Closewin
END SUB
SUB Errmsg(what)
CALL Openwin(13,44,5,32,attr(15,4),attr(15,4),1,8,1,0)
SELECT CASE what
CASE 3
CALL Printcwin(1,"YOU MUST PROVIDE INPUT")
CALL Printcwin(2,"FOR ALL THREE FIELDS")
CALL Printcwin(3,"Press any key to continue ")
END SELECT
CALL Getkey(ch1$,ch2$)
CALL Closewin
END SUB
FUNCTION Frac##(num##)
Frac## = num## - INT(num##)
END FUNCTION
FUNCTION Powerof## (number##, power)
Powerof## = EXP10(power * LOG10(number##))
END FUNCTION
SUB Compute.Payment(amt##,rt##,mo)
LOCAL hold##
IF (amt## > 0.0) AND (mo > 0) AND (rt## > 0.0) THEN
hold## = powerof##(1.0 + rt## / 1200.0, mo)
payment## = ((rt## / 1200.0) * hold## * amt##) / (hold## - 1.0)
payment## = payment## + 0.005
hold## = frac##(payment## * 100.0)
payment## = ((payment## * 100.0)-hold##)/100.0
CALL Windowxy(5,21)
print using "######.##";payment##;
ELSE
CALL Errmsg(3)
END IF
END SUB
SUB Help.Message(what)
CALL Openwin(6+what,38,8,36,attr(0,2),attr(0,2),2,8,1,0)
CALL Sprint(6+what,38,CHR$(17),attr(0,2))
SELECT CASE what
CASE 1
CALL Titlewin(2,attr(15,2),"[ Principal Amount ]")
CALL Printwin(1,2,"Enter the amount of the loan you")
CALL Printwin(2,2,"wish to calulate. The format is")
CALL Printwin(3,2,"######.##. Do not enter a")
CALL Printwin(4,2,"negative number.")
CASE 2
CALL Titlewin(2,attr(15,2),"[ Interest Rate ]")
CALL Printwin(1,2,"Enter the interest rate for the")
CALL Printwin(2,2,"the loan you wish to calculate.")
CALL Printwin(3,2,"The format is ##.##. Where 11%")
CALL Printwin(4,2,"would be entered as 11.00. Do")
CALL Printwin(5,2,"not enter a negative number.")
CASE 3
CALL Titlewin(2,attr(15,2),"[ No. of Payments ]")
CALL Printwin(1,2,"Enter the number of payments for")
CALL Printwin(2,2,"the loan you wish to calulate.")
CALL Printwin(3,2,"The format is ####. Enter the")
CALL Printwin(4,2,"actual number of payments not the")
CALL Printwin(5,2,"number of years. Do not enter a")
CALL Printwin(6,2,"negative number.")
END SELECT
CALL Titlewin(5,attr(15,2)," Press any key to continue ")
CALL Getkey(ch1$,ch2$)
CALL Closewin
END SUB
' ********** END OF PROGRAM **********