Category : Dbase (Clipper, FoxBase, etc) Languages Source Code
Archive   : EXPAND30.ZIP
Filename : EXPDEMO.PRG

 
Output of file : EXPDEMO.PRG contained in archive : EXPAND30.ZIP

* ------------------------------------------------------------------------
* Program......: EXPDEMO.PRG, Demo of EXPAND.LIB v3.0
* Author.......: Pepijn Smits.
* Version......: 3.0
* Date.........: Jan 1990 v1, May v1.5, Aug v2.0, Oct v2.5.
* Copyright....: (c)1990, Pepijn Smits.
* Notes........: Clipper 'Demo' program of some of the functions in the
* Expand Library. This program demonstrates most of EXPAND's
* functions
* ------------------------------------------------------------------------
*
* Be sure to Link in EXPAND.LIB next to CLIPPER and EXTEND!
*
PUBLIC x
set date british
set score off

StartTimer()
init()
MouseInit()

clear

header()
status()

x = Menu(1)
do while .t.
do case
case x = 0
begin sequence
if Ask('Are you sure you want to quit?')
set color to
clear
?? 'Goodbye from the Expand library demo program active for '+TimerStr()
?
quit
endif
end

case x = 1
changeDrive()

case x = 2
Demo123()

case x = 3
BannerTest()

case x = 4
MakeDir()

case x = 5
Uptest()

case x = 6
dial()

case x = 7
* Boot?
begin sequence
if ask('Sure you wanna reboot the computer?')
reboot()
endif
end

case x = 8
Keyrate()

case x = 9
SystemDate()

case x = 10
deltest()

case x = 11
if PrintCheck()
PrintSubmit()
endif

case x = 12
if PrintCheck()
PrintCancel()
endif

case x = 13
if PrintCheck()
begin sequence
if ask('Cancel ALL files from PRINT?')
CancelAll()
endif
end
endif

case x = 14
if PrintCheck()
PrintStatus()
endif

endcase
status()
x = Menu(x)
enddo

function init
private x
x = vmode()
if x <= 1 && make sure screen is 80 columns wide(Mode 2,3 or 7)
vmode( x+2 )
x = vmode()
elseif x >= 4 .and. x <> 7
* - We're talking Graphics mode here..
? chr(7) && Beep
quit
endif
* - Check if Help requested..
*
if At('?',CommandLine()) <> 0
?? 'Expand Library v3.0 DEMO program, written by Pepijn Smits.'
? 'Demo of Expand.Lib features, written for Clipper S87.'
?
? 'Enter "ExpDemo /BW" to force a Black & White screen.'
?
quit
endif
* - Set Colors (only if Non BW conditions met)
*
if .not. ( x=2 .or. x=7 .or. At('/BW',Upper(CommandLine()))<>0 )
Set color to "w+/b,n/bg"
endif
return(0)


function Menu
parameter x
declare r[14],c[14],p[14]
@ 4,0 to 19,29
Msg('[F1]-Help, [Up/Down]-Move Bar or use Mouse',;
'[Enter]-Do Selection, [Esc]-Quit')

r[ 1] = 5
c[ 1] = 1
p[ 1] = " Change drive "
r[ 2] = 6
c[ 2] = 1
p[ 2] = " Create a 1-2-3 file "
r[ 3] = 7
c[ 3] = 1
p[ 3] = " Banner test "
r[ 4] = 8
c[ 4] = 1
p[ 4] = " Make Directory "
r[ 5] = 9
c[ 5] = 1
p[ 5] = " Uppercase Test "
r[ 6] = 10
c[ 6] = 1
p[ 6] = " Dialing Voice Test "
r[ 7] = 11
c[ 7] = 1
p[ 7] = " Reboot Computer "
r[ 8] = 12
c[ 8] = 1
p[ 8] = " Set Typematic Rate "
r[ 9] = 13
c[ 9] = 1
p[ 9] = " Set System date & Time "
r[10] = 14
c[10] = 1
p[10] = " Delete file(s) Test "
r[11] = 15
c[11] = 1
p[11] = " Submit file to PRINT "
r[12] = 16
c[12] = 1
p[12] = " Cancel file(s) from PRINT "
r[13] = 17
c[13] = 1
p[13] = " Cancel All files in PRINT "
r[14] = 18
c[14] = 1
p[14] = " Show PRINT status "
Return (MouseMenu(r,c,p,x))

Function header
@ 0,0 to 3,79
center(1,'EXPAND Library v3.0')
center(2,'Demo of the main features of the library')
return(0)

Function Status
@ 4,30 clear to 19,79
@ 4,30 to 19,79
@ 5,31 say "DOS version........: "+DosVersion()
@ 6,31 say "DOS default disk...: "+Chr( GetDisk() + 65 )+':'
@ 7,31 say "Free disk space....: "+Str(DiskSpace(),10)+" Bytes."
@ 8,31 say "Total disk space...: "+Str(DiskTotal(),10)+" Bytes."
@ 9,31 say "Disk Fixed?........: "+iif(DiskFixed(),'Yes.','No. ')
@10,31 say "Disk Remote?.......: "+iif(DiskRemote(),'Yes.','No. ')
@11,31 say "Valid drives are...: A: thru "+Chr( LastDisk() + 65 )+':'
@12,31 say "PRINT installed?...: "+iif(PrintThere(),'Yes.','No. ')
@13,31 say "My Name is.........: "+;
iif( DOSmajor() < 3 ,'(Not available)',MyName() )
@14,31 say "Processor..........: "+CPUname()
@15,31 say "The ROM is dated...: "+DtoC( ROMdate() )
@16,31 say "Machine type.......: "+MachineType()
@17,31 say "Real-Time date.....: "+Dtoc( RealDate() )
@18,31 say "Real-Time time.....: "+RealTime()
return(0)

function MachineType
* you are encouraged to adapt this function for it
* to support more and more computers
do case
case ROMid()=255
return "IBM PC (Hey, that's an oldy!)"
case ROMid()=254 .or. ROMid()=251
return "IBM XT Compatible"
case ROMid()=253
return "IBM PCjr (Really?)"
case ROMid()=252
return "IBM AT Compatible"
otherwise
return "(Unknown ID)"
endcase

Procedure Help
*
* Demo Help function..(get back in the same state)
*
private Cursor, Color, Row, Col, Screen

* - Store the current State
Cursor = SetCursor(.f.)
Color = SetColor(iif(vmode()=3,"w/r,n/w","n/w,w/n"))
Row = Row()
Col = Col()
Save Screen to Screen

@ 8,15 clear to 14,65
@ 8,15 to 14,65
center(9,'Expand Demo (Dummy) Help Window')
center(10,'----------------------------------------')
center(11,'Just there to test and show the working')
center(12,'of some routines from Expand.Lib')
center(14,' Press any key to continue.. ')
MouseKey()

* - Restore the state
@ Row, Col
Restore Screen from screen
SetColor(Color)
SetCursor(Cursor)

return

* ---------------------------------------------------------------------------
* General demo routines
* ---------------------------------------------------------------------------

Function ChangeDrive
private i
i = lastdisk()+1
declare r[i],c[i],p[i]
msg('Select the new DOS default drive..','')
for i = 0 to lastdisk()
r[i+1] = 22
c[i+1] = 40 - ( 5*(lastdisk()+1)/2) + 5*i
p[i+1] = " "+Chr(65+i)+": "
next
i = MouseMenu(r,c,p,GetDisk()+1)
if i != 0
* - We're changing the Drive..
if DOSmajor() >= 3 .and. DOSminor() >= 20
* - Check for Logical drive acces if DOS 3.20 +
if GetDrive(i) <> 0
if GetDrive(i) <> i
Msg('Enter Disk for Drive '+Chr(64+i)+': And',;
'Press any key to Continue')
MouseKey()
SetDrive(i) && Set the drive as Being last accessed.
endif
endif
endif
SetDisk(i-1)
if GetDisk() <> i-1
Msg('Sorry, It seems that drive '+chr(64+i)+': is invalid..')
MouseKey()
endif
endif
return (0)

Function ChangeDir
if ChDir( Prompt('Enter directory to change to:','\'+GetDir()) ) == 0
Msg('Okay')
else
Msg('Invalid directory!')
endif
MouseKey()
return (0)

Function MakeDir
if MkDir( Prompt('Enter directory to create:','\'+GetDir()) ) == 0
Msg('Directory Created Ok!')
else
Msg('Unable to create directory')
endif
MouseKey()
return (0)

Function RemoveDir
if RmDir( Prompt('Enter directory to Remove:','\'+GetDir()) ) == 0
Msg('Directory removed..')
else
Msg("Couldn't remove directory")
endif
MouseKey()
return (0)

Function UpTest
begin sequence
Msg('The Real Uppercase of that string is:',;
Uppercase( Prompt('Uppercase test: Enter a string..',;
"Fran‡oise et D‚d‚, mˆme … Paris..") ))
MouseKey()
end
return(0)

Function Deltest
*
private mask
begin sequence
mask = Prompt('Delete test: Enter file mask (no leading path)','')
if len(mask)=0
msg('Empty Mask not allowed')
else
if ask('Delete file(s) matching ['+mask+'], Are you sure?')
if del(mask)
Msg('File(s) deleted Ok..')
else
Msg('No matching file(s)')
endif
else
Msg('Not deleted.')
endif
endif
MouseKey()
end
return(0)


Function Dial
private port,prefix,Number,i
begin sequence
declare r[4],c[4],p[4]
for i = 1 to 4
r[i] = 22
c[i] = 16 + 8*i
p[i] = ' COM'+Str(i,1)+': '
next
msg('Select port where Modem is connected','')
port = MouseMenu(r,c,p)
if port=0
break
endif
port = port-1
prefix = iif(ask('Voice Dialing Test, Use Tone dialing?'),'ATDT','ATDP')
if lastkey()=27
return(0)
endif
number = prompt('Please Enter Number to dial:','')
if lastkey()=27
return(0)
endif
dtr(.t.,port)
atmodem( prefix+Number+';',port)
msg('Dialing '+Number+'..',;
'Pick up phone any time and press a key when the phone rings')
MouseKey()
dtr(.f.,port)
end
return(0)

Function KeyRate
private x
Declare r[2],c[2],p[2]
Msg('Set the typematic rate to..','')
r[1] = 22
c[1] = 34
p[1] = " Fast "
r[2] = 22
c[2] = 41
p[2] = " Slow "
x = MouseMenu(r,c,p)
do case
case x == 1
fastkey()
case x == 2
slowkey()
endcase
return(0)


Function SystemDate
Private d,t,h,m,s
msg('','')
d = date()
t = time()
@ 21,30 Say "(Enter date in European format)"
@ 22,30 Say "(Enter time in 24 hour format)"
@ 21,1 Say "Enter new date" get d picture "D"
@ 22,1 say "Enter new time" get t picture "99:99:99"
read
if lastkey()<>27
setdate(d)
settime(t)
endif
return (0)


function Bannertest
*
* test the Banner() function!
*
private scr,s,i
save screen to scr
begin sequence
s = SubStr(prompt('Enter String to Banner (to a maximum of 9 characters)','Expand!'),1,9)
@ 7,3 clear to 16,76
@ 7,3 to 16,76
* - Print out every line of the bannered string.
for i = 1 to 8
@ 7+i,4 say banner(i,s)
next
center(7,' The string, Bannered.. ')
center(16,' Press any key to continue ')
MouseKey()
end
restore screen from scr
return(0)


function Demo123
*
* Just some simple routine that creates EXPAND.WK1 with some Info in it..
*
Msg('Creating EXPAND.WK1..')
if Create123('EXPAND.WK1',5,1)
Width123(0,20)
Width123(1,40)
Write123(0,0,'Ah! There you are!')
Write123(0,1,'Yes, I was just created by EXPAND.LIB!.')
Write123(1,0,2342)
Write123(1,1,'<- a number')
Write123(2,0,7623.2393,2)
Write123(2,1,'<- a number with 2 decimals..')
Write123(3,0,date())
Write123(3,1,'<- this should be today..')
Write123(4,0,StoD('19670308'))
Write123(4,1,'<- and this is my birthdate..')
Write123(5,0,'That was it..')
Write123(5,1,'Okidoki.. Return to the EXPAND.LIB now..')
Close123()
Msg('Created EXPAND.WK1','Use 1-2-3 to see what is in it!')
else
Msg('Could not create EXPAND.WK1!')
endif
MouseKey()
return (0)


* ---------------------------------------------------------------------------
* PRINT demo routines..
* ---------------------------------------------------------------------------

Function PrintCheck
*
* report whether print is there..
*
if .not. PrintThere()
Msg('PRINT is not installed, intall it before testing the Lib!')
MouseKey()
return .f.
else
return .t.
endif

Function printsubmit
private x
x = qualify( prompt('Enter filename to submit to PRINT :','') )
if ask('Submit ['+x+'] to Print?')
submitfile(x)
* don't care about result.. we'll see the status()..
endif
return (0)

Function printcancel
private x
x = qualify( prompt('Enter file(s) to cancel from PRINT (wildcards Ok) :','') )
if ask('Cancel files matching ['+x+'] from Print?')
cancelfile(x)
endif
return (0)

Function PrintStatus
private i,Count
begin sequence
@ 4,30 clear to 19,79
@ 4,30 to 19,79
@ 5,31 say "PRINT status:"
@ 6,31 say "Errors trying to output last character : "+str(PrintError(),6)
@ 7,31 say "The file(s) in the Print queue:"
if PrintCount() == 0
@ 8,31 say "(none)"
else
* - Fill Array with Current PRINT files..
Count = Aprint()
Declare A[count]
Aprint(A)
for i = 1 to PrintCount()
@ 7+i,31 say A[i]
next
endif
if ask('Do you want PRINT to continue outputting characters?')
Printresume()
endif
end
return (0)


* ---------------------------------------------------------------------------
* GENERAL PURPOSE ROUTINES
* ---------------------------------------------------------------------------

Function Msg
* Put up to 3 messages on the bottom of the screen..
parameter s,t,v
@ 20,0 clear
@ 20,0 to 21+pcount(),79
center(21,s)
if pcount() >= 2
center(22,t)
endif
if pcount() >= 3
center(23,v)
endif

Function Prompt
parameter s,orig
msg('','')
@ 21,1 say s
orig = orig + space(78 - len(orig))
@ 22,1 get orig picture '@X'
read
if lastkey()=27
break
endif
return Alltrim(orig)

Function Center
parameter Row,S
@ Row, 40 - (len(s)/2) say s
return(0)

Function Ask
parameter s
private choice
declare r[2],c[2],p[2]
@ 20,0 clear
@ 20,0 to 23,79
center(21,s)
r[1] = 22
c[1] = 35
p[1] = " No "
r[2] = 22
c[2] = 41
p[2] = " Yes "
Choice = MouseMenu(r,c,p)
if Choice==0
Break && branch to END on Escape..
Endif
Return ( Choice==2 )