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 )


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

  1. Very nice! Thank you for this wonderful archive. I wonder why I found it only now. Long live the BBS file archives!

  2. This is so awesome! 😀 I’d be cool if you could download an entire archive of this at once, though.

  3. But one thing that puzzles me is the “mtswslnkmcjklsdlsbdmMICROSOFT” string. There is an article about it here. It is definitely worth a read: http://www.os2museum.com/wp/mtswslnk/