home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / CLIPPER / DATABASE / EXPAND52.ZIP / EXPDEMO.PRG < prev    next >
Encoding:
Text File  |  1991-06-17  |  14.7 KB  |  506 lines
  1. * ------------------------------------------------------------------------
  2. * Program.....:    EXPDEMO: Expand library v2.0 program, New version.
  3. * Author......:    Pepijn Smits.
  4. * Date........:    Jun 1991
  5. * Copyright...:    (c)1991, Pepijn Smits Software, Rotterdam.
  6. * Notes.......:    Clipper 5.01 Demo of Expand library v2.00
  7. *        You may use parts of this program in Your own applications,
  8. *        providing you do not distribute it in source code-form,
  9. *        without mentionning the source (ie. Expand). Linking
  10. *        without mentionning is thus OK (also applies to the library).
  11. * ------------------------------------------------------------------------
  12. * Compile and Link as Follows:
  13. * >Clipper EXPDEMO
  14. * >RTlink fi EXPDEMO li EXPAND [verbose] [/pll:base50]
  15. * Run EXPDEMO /BW for Black&White monitors on Color systems and Laptops
  16.  
  17. SetupScreen()
  18. MyMenu()
  19. Set Color To
  20. @ MaxRow(),0
  21. Quit
  22.  
  23. * ==================== MENU  Routines =================
  24.  
  25. Function MyMenu
  26. Local x
  27. Local Scr := ScrSave()
  28. /* 
  29.    Define the Menus choices in an Array, also place the Code to execute
  30.    as the 5th array entry, as that one is not used by MouseMenu() itself.
  31.    Each entry is: { Row, Col, MenuPrompt, Msg Code-Block, Menu Code-Block }
  32. */
  33. Local Mnu := {     ;
  34.     {  5, 31," Change Drive      " , ;
  35.         {||BottomMsg('Select the Default Drive')}, ;
  36.         {||ChangeDrive()  } }, ;
  37.     {  6, 31," Directory Tree    " , ;
  38.         {||BottomMsg('Show Directory Tree')}, ;
  39.         {||TreeTest()   } }, ;
  40.     {  7, 31," Show Status       " , ;
  41.         {||BottomMsg('Show Current status')} , ;
  42.         {||Status()     } }, ;
  43.     {  8, 31," Write to 1-2-3    " , ;
  44.         {||BottomMsg('Create a Sample .WK1 sheet')} , ;
  45.         {||Test123()    } }, ;
  46.     {  9, 31," Real Uppercase    " , ;
  47.         {||BottomMsg('Test the Uppercase() function')} , ;
  48.         {||TestUp()     } }, ;
  49.     { 10, 31," Dialing Voice     " , ;
  50.         {||BottomMsg('Use your Modem to Dial a number')} , ;
  51.         {||TestDial()   } }, ;
  52.     { 11, 31," Reboot Computer   " , ;
  53.         {||BottomMsg('Reboot the Computer from program')}, ;
  54.         {||if(ask('Reboot','Are you sure you want to reboot?'),Reboot(),NIL) } }, ;
  55.     { 12, 31," Typematic Rate    " , ;
  56.         {||BottomMsg('Select the typematic rate')} , ;
  57.         {||TestType()   } }, ;
  58.     { 13, 31," Environment Test  " , ;
  59.         {||BottomMsg('Test of Environment Functions')} , ;
  60.         {||EnvTest()    } }, ;
  61.     { 14, 31," PRINT Tests       " , ;
  62.         {||BottomMsg('Use the PRINT interface')} , ;
  63.         {||PRINTtest()  } }, ;
  64.     { 15, 31," ROM Scan Test     " , ;
  65.         {||BottomMsg('Let us have a look at what kind of Computer you have')}, ;
  66.         {||ROMScanTest()} }, ;
  67.     { 16, 31," Encode Test       " , ;
  68.         {||BottomMsg('Test the Encode() and Decode() functions')}, ;
  69.         {||EncodeTest() } }, ;
  70.     { 17, 31," Shell to DOS Test " , ;
  71.         {||BottomMsg('Shell to DOS, with new PROMPT setting')}, ;
  72.         {||DOSshell()   } } }
  73.  
  74. MyBox(4,29,18,51,'Menu')
  75. x := 1
  76. While x<>0
  77.     x := MouseMenu(Mnu,x)
  78.     if (x<>0)
  79.         Eval(Mnu[x,5])
  80.     else
  81.         x := if(ask('Quit','Are you sure you want to Quit?'),0,1)
  82.     end
  83. end
  84. ScrRestore(Scr)
  85. Return (NIL)
  86.  
  87. * ==================== GENERAL SCREEN ROUTINES ===================
  88.  
  89. Function SetupScreen
  90. Local i
  91.  
  92. /* Fill Screen with ░'s by using RestScreen() */
  93. RestScreen(1,0,MaxRow(),MaxCol(),Replicate('░'+chr(7),(MaxCol()+1)*MaxRow()))
  94.  
  95. /* Make a nice banner in the background */
  96. Set Color to
  97. for i := 1 to 8 
  98.    @ i+3,8 say  StrTran(Banner(i," Expand"),chr(32),chr(176))
  99.    @ i+12,8 say StrTran(Banner(i,"Library!"),chr(32),chr(176))
  100. next
  101.  
  102. SetColor(NormColor())
  103. @ 0,0
  104. Center(0,' Clipper 5.01 » Expand Library v2.00 » Demonstration Program ')
  105.  
  106. return (NIL)
  107.  
  108. * ====================== Status =====================================
  109.  
  110. Function Status
  111. /* Make a huge "OK" message */
  112. Local x := ScrSave()
  113.  
  114. Msg('Status','Status is Coming right Up!',MsgColor())
  115.  
  116. OkMsg('Status',;
  117.  "DOS version : "+DosVersion()+";"+;
  118.  "DOS default disk : "+Chr( GetDisk() + 65 )+':'+";"+;
  119.  "Free disk space : "+Str(DiskSpace(),10)+" Bytes."+";"+;
  120.  "Total disk space : "+Str(DiskTotal(),10)+" Bytes."+";"+;
  121.  "Disk Fixed? : "+iif(DiskFixed(),'Yes.','No. ')+";"+;
  122.  "Disk Remote? : "+iif(DiskRemote(),'Yes.','No. ')+";"+;
  123.  "Valid drives are : A: thru "+Chr( LastDisk() + 65 )+':'+";"+;
  124.  "PRINT installed? : "+iif(PrintThere(),'Yes.','No. ')+";"+;
  125.  "My Name is : "+if( DOSmajor() < 3 ,'(Not available)',MyName() )+";"+;
  126.  "Mouse Installed : "+iif(MouseThere(),'Yes.','No. ')+";"+;
  127.  "The ROM is dated : "+DtoC( ROMdate() )+";"+;
  128.  "Processor : "+CPUname()+";"+;
  129.  "Append's Path : "+if(AppendThere(),AppendPath(),'(Not Installed)')+";"+;
  130.  "Keyboard code : "+if(Len(KeybCode())=0,'US (Standard)',KeybCode()) )
  131.  
  132. ScrRestore(x)
  133. Return (NIL)
  134.  
  135. * ======================= MISC TEST ROUTINES ============================
  136.  
  137. Function EncodeTest
  138. Local x
  139. x := Prompt('Encode Test','Enter string to Encode','')
  140. OkMsg('Encode Test','The Encoded string of;'+x+';is;'+Encode(x,'EXPAND')+;
  141.     ';(Using EXPAND as key)',msgColor())
  142. Return (NIL)
  143.  
  144. Function TestUp
  145. Local x := 'Préäçêköròtôÿpû, John (strange name huh?)'
  146. x := Alltrim(Prompt('Uppercase Test','Enter string to Uppercase',x))
  147. OkMsg('Uppercase Test','The Uppercase of;'+x+';is;'+Uppercase(x),msgColor())
  148. Return (NIL)
  149.  
  150. Function ROMscanTest
  151. Local x
  152. x := (Prompt('ROM scan','Enter ID string to look for in ROM',''))
  153. if ROMscan(x)
  154.     OkMsg('ROM scan','Well, It seems that you computer is a;'+;
  155.     x+';(string was Found in ROM)',msgColor())
  156. else
  157.     OkMsg('ROM scan','Sorry, but your computer is not a;'+;
  158.     x+';(string was Not found in ROM)',msgColor())
  159. end
  160. Return (NIL)
  161.  
  162. Function DOSshell
  163. Local Scr := ScrSave()
  164. if SetEnv('PROMPT','EXPAND DEMO Shell, Type EXIT to resume$_'+GetEnv('PROMPT'))
  165.     * - Have to set Ptr to Env when Shelling, and restore current (of Course)
  166.     set Color to
  167.     cls
  168.     Msg('Shell','Shelling to DOS',NormColor())
  169.         @ MaxRow(),0
  170.     x = EnvPtr(EnvOrig())
  171.     !Command
  172.     EnvPtr(x)
  173.     * - Restoring Original Prompt. (Use Gete() and .Not. ReadEnv()!!)
  174.     SetEnv('PROMPT',GetEnv('PROMPT'))
  175. else
  176.     OkMsg('Shell Problem','Not enough room in environment to change PROMPT;Program will not Shell..')
  177. end
  178. scrRestore(Scr)
  179. Return (NIL)
  180.  
  181. Function ChangeDrive
  182. Local i
  183. Local DriveMenu := {}
  184. For i := 0 to lastdisk()
  185.     aAdd(DriveMenu, Chr(65+i)+":")
  186. Next
  187. i := MyAlert('Default drive','Select the New default drive',DriveMenu,MsgColor())
  188. if i != 0
  189.    /* We're changing the Drive.. */
  190.    if DOSvalue() >= 3.20
  191.       /* Check for Logical drive acces if DOS 3.20 + */
  192.       if GetDrive(i) <> 0
  193.          if GetDrive(i) <> i
  194.             OkMsg('Drive Select','Physical drive was not last accessed as this drive;'+;
  195.         'Enter Disk for Drive '+Chr(64+i)+':')
  196.         SetDrive(i)         /* Set the drive as Being last accessed */
  197.          end
  198.       end
  199.    end
  200.    SetDisk(i-1)            /* select Default Disk */
  201.    if GetDisk() <> i-1 
  202.       OkMsg('Invalid Drive','Sorry, It seems that drive '+chr(64+i)+': is invalid..')
  203.    end
  204. end
  205. Return (NIL)
  206.  
  207. Function Test123
  208. Local Scr := ScrSave()
  209. Msg('1-2-3 Test','Creating EXPAND.WK1..',MsgColor())
  210. if Create123('EXPAND.WK1',5,1)
  211.     Width123(0,20)
  212.     Width123(1,40)
  213.     Write123(0,0,'Ah! There you are!') 
  214.     Write123(0,1,'Yes, I was just created by EXPAND.LIB!.')
  215.     Write123(1,0,2342)
  216.     Write123(1,1,'<- a number')
  217.     Write123(2,0,7623.2393,2)
  218.     Write123(2,1,'<- a number with 2 decimals..')
  219.     Write123(3,0,date())
  220.     Write123(3,1,'<- this should be today..')
  221.     Write123(4,0,StoD('19670308'))
  222.     Write123(4,1,'<- and this is my birthdate..')
  223.     Write123(5,0,'That was it..')
  224.     Write123(5,1,'Okidoki.. Return to the EXPAND.LIB now..')
  225.     Close123()
  226.     OkMsg('1-2-3 Test','Created EXPAND.WK1;Use 1-2-3 to see what is in it!',MsgColor())
  227. else
  228.     okMsg('Error','Could not create EXPAND.WK1!',ErrColor())
  229. end
  230. scrRestore(Scr)
  231. return (NIL)
  232.  
  233. Function TestDial
  234. Local port,prefix,Number,i
  235. Local prtMenu := {}
  236. Local Scr := ScrSave()
  237. for i := 1 to 4 
  238.    aAdd(prtMenu,'COM'+Str(i,1)+':')
  239. next
  240. Port := MyAlert('Voice Dial','Select port where Modem is connected',PrtMenu)
  241.  
  242. /* If Port was selected, Go On */
  243. if Port<>0
  244.     Port--
  245.     /* Is there a Damn COM port anyway? */
  246.     if IsPort(Port)
  247.         prefix := If(MyAlert('Dial','Which dialing mode shall I use?',;
  248.             {'Tone','Pulse'})=1,'ATDT','ATDP')
  249.         Number := prompt('Dial','Please Enter Number to dial:','')
  250.         Dtr(.t.,port)
  251.         AtModem( prefix+Number+';',port)
  252.         Msg('Dialing','Currently dialing;'+Number+';'+;
  253.              'Pick up phone any time and;press a key or the Mouse;when the phone rings')
  254.         MouseKey()
  255.         dtr(.f.,port)
  256.     else
  257.         OKmsg('Dial','You selected an Un-Installed Port!')
  258.     end
  259. end
  260. ScrRestore(Scr)
  261. return (NIL)
  262.  
  263. Function TestType
  264. Local x:=MyAlert('Typematic Rate','Set the Type-matic rate to',{"Fast","Slow","Don't care"})
  265. if x = 1
  266.     fastkey()
  267. elseif x = 2
  268.     slowkey()
  269. end
  270. return (NIL)
  271.  
  272. Function PRINTtest
  273. okMsg('PRINT',"Sorry, haven't had the time to write the PRINT;"+;
  274.     "test routines yet, but they all work allright;"+;
  275.     "I can assure you that..")
  276. Return (NIL)
  277.  
  278. * ===================== Directory Tree Routines ==========================
  279.  
  280. Function TreeTest
  281. Local aTree := {}, aPath := {}, x, i
  282. Local Scr := ScrSave()
  283.  
  284. SetColor(NormColor())
  285. MyBox(3,8,20,72,'Directory Tree')
  286.  
  287. @ 4,11 say 'Select Directory:'
  288. @ 5,11 say replicate('─',59)
  289.  
  290. /* Dirtree will scan the whole tree */
  291. Msg('Scanning',' Disk for directories..;   ',MsgColor())
  292. SetColor(MsgColor())
  293.  
  294. i := 1
  295. DirTree("\","\ (Root directory)",;
  296.     aTree,aPath,{|s|Center(MidRow(),Str(i++,4))},"","")
  297.  
  298. SetColor(NormColor())
  299. MouseChoice(6,11,19,69,aTree)
  300.  
  301. OkMsg('Notice','By the way, directory;was not changed')
  302. ScrRestore(Scr)
  303.  
  304. Return (NIL)
  305.  
  306. /*
  307. DirTree: Nice recursive procedure that fills two Arrays
  308.          With directory information
  309. */
  310.  
  311. Procedure DirTree(cDir,cDirName,aTree,aPath,bMsg,s0,s1)
  312. Local aDir := {}
  313. Local x
  314. Local Code,DTA := Space(43)
  315.  
  316. /* Add the current entries to the Tree data */
  317. aAdd(aTree,s0+cDirName)
  318. aAdd(aPath,cDir)
  319.  
  320. /* Evaluate the Code block */
  321. Eval(bMsg,cDir)
  322.  
  323. /* Get the directories in this dir */
  324. Code := FindFirst(cDir+'*.*',16,@DTA)
  325. While (Code=0) .and. ((FindName(DTA)='..') .or. (FindName(DTA)='.'))
  326.     Code := FindNext(@DTA)
  327. end
  328.  
  329. While Code=0
  330.     if FindAttr(DTA)=16
  331.         aAdd(aDir,FindName(@DTA))
  332.     end
  333.     code := FindNext(@DTA)
  334. End
  335.  
  336. /* if any subdirectories */
  337. if len(aDir) > 0
  338.     /* And now, recurse into the Tree... */
  339.     for x := 1 to Len(aDir)-1
  340.         DirTree(cDir+aDir[x]+'\',aDir[x],aTree,aPath,bMsg,s1+"├──",s1+"│  ")
  341.     next
  342.     x := Len(aDir)
  343.     DirTree(cDir+aDir[x]+'\',aDir[x],aTree,aPath,bMsg,s1+"└──",s1+"   ")
  344. endif
  345. /* That's it! */
  346. Return
  347.  
  348. * =================== ENVIRONMENT TEST ROUTINES =======================
  349.  
  350. Function EnvTest
  351. Local Scr := ScrSave()
  352. Local aEnv[EnvCount()]
  353. Local i
  354.  
  355. for i:=1 to EnvCount()
  356.     aEnv[i] := EnvStr(i)
  357. next
  358.  
  359. MyBox(6,8,20,72,'Environment variables information')
  360.  
  361. @  8,11 say "Number of Enviroment strings....."+str(EnvCount())
  362. @  9,11 say "Bytes in use by Environment......"+str(EnvUsed())
  363. @ 10,11 say "Bytes allocated to Environment..."+str(EnvSize())
  364. @ 12,11 say "The Environment strings:"
  365. @ 13,11 say Replicate('─',60)
  366.  
  367. BottomMsg('Press Enter or Escape (or click) to resume, No editing allowed for security')
  368. MouseChoice(14,11,19,70,aEnv)
  369. ScrRestore(Scr)
  370. return (NIL)
  371.  
  372. * ================== BASIC SCREEN ROUTINES =======================
  373.  
  374. Function MidCol            /* Middle Column value */
  375. Return (MaxCol()+1)/2
  376.  
  377. Function MidRow            /* Middle Row */
  378. Return (MaxRow()+1)/2
  379.  
  380. Function ScrSave
  381. /* Saves screen and Status */
  382. Return ({PackScr(SaveScreen(0,0,MaxRow(),MaxCol())),Row(),Col(),SetColor()})
  383.  
  384. Function ScrRestore(S)
  385. /* Restores It */
  386. Restscreen(0,0,MaxRow(),MaxCol(),UnpackScr(s[1]))
  387. DevPos(s[2],s[3])
  388. setColor(s[4])
  389. Return (NIL)
  390.  
  391. Function Ask(Title,cText,Color)
  392. Return (MyAlert(Title,cText,{"No","Yes"},Color)=2)
  393.  
  394. Function Center(Row,S)
  395. @ Row, (MidCol() - (Len(s)/2)) SAY S
  396. return (NIL)
  397.  
  398. Function CenterBox(w,h,Title)
  399. MyBox(MidRow()-(h/2),MidCol()-(w/2),MidRow()+(h/2),MidCol()+(w/2),Title)
  400. Return (NIL)
  401.  
  402. Function BottomMsg(s)
  403. Local C := SetColor(NormColor())
  404. @ MaxRow(),0
  405. @ MaxRow(),0 say s
  406. SetColor(C)
  407. Return (NIL)
  408.  
  409. Function Msg(Title,cText,cColor)
  410. Local aText := aDelimit(cText)
  411. Local i := MidRow() - (Len(aText)/2)
  412. Local oldColor := SetColor(if(cColor<>NIL,cColor,SetColor()))
  413. CenterBox(aMaxLen(aText)+2,Len(aText)+2,Title)
  414. aEval(aText,{|s|Center(i++,s)})
  415. SetColor(oldColor)
  416. Return (NIL)
  417.  
  418. Function Prompt(Title,Text,Default)
  419. Local Scr := ScrSave()
  420. Local x
  421. SetColor(MsgColor())
  422. Default := SubStr(Padr(Default,58),1,58)
  423. MyBox(9,9,12,71,Title)
  424. @ 10,11 say Text
  425. x := MouseGet(11,11,Default)
  426. ScrRestore(Scr)
  427. Return Alltrim(x)
  428.  
  429. Function okMsg(Title,cText)
  430. MyAlert(Title,cText)
  431. Return (NIL)
  432.  
  433. Function MyBox(t,l,b,r,Title)
  434. Shadow(t-1,l-3,b+1,r+3,if(ColorOn(),8,7))
  435. @ t-1,l-3 clear to b+1,r+3
  436. @ t,l TO b,r DOUBLE
  437. center(t,' '+title+' ')
  438. Return (NIL)
  439.  
  440. * =================== Alternative Alert Function ===================
  441.  
  442. Function MyAlert(cTitle,cMsg,aOptions,cColor)
  443. Local aMenu := {}            /* Will contain Menu Choices */
  444. Local nTop,nLeft,nBottom,nRight
  445. Local x,MaxLen,SaveScr
  446. Local aMsg := aDelimit(cMsg)        /* Expand cMsg into Array of strings */
  447.  
  448. cColor :=   if(cColor=NIL,If(IsColor(),MsgColor(),''),cColor)
  449. aOptions := if(aOptions=NIL,{"Ok"},aOptions)
  450.  
  451. x := 0                    /* Get Length of Options Line */
  452. aEval(aOptions,{|s|x+=4+Len(s)})    /* 4 spaces more/option */
  453. MaxLen := Max(aMaxLen(aMsg),x)        /* Max String length test */
  454. nTop := MidRow()-(Len(aMsg))/2 - 3    /* Set Coordinates */
  455. nLeft := MidCol()-(MaxLen)/2 - 2
  456. nBottom := nTop + len(aMsg) + 4
  457. nRight := nLeft + MaxLen + 3
  458. SaveScr := ScrSave()
  459. SetColor(cColor)
  460. MyBox(nTop,nLeft,nBottom,nRight,cTitle)
  461. x := MidCol()-x/2            /* Put options in aMenu (MouseMenu) */
  462. aEval(aOptions,{|s|aAdd(aMenu,{nBottom-2,x+1,' '+s+' '}),x+=4+len(s)})
  463. x := nTop+1                /* Draw strings */
  464. aEval(aMsg,{|s|Center(x++,s)})
  465.  
  466. x := MouseMenu(aMenu)            /* Get the option */
  467. ScrRestore(SaveScr)
  468. Return (x)                /* And return the choice */
  469.  
  470. Static Function aMaxLen(a)
  471. /* Return Length of largest string in array */
  472. Local MaxLen := 0
  473. aEval(a,{|s|MaxLen:=Max(Len(s),MaxLen)})
  474. return (MaxLen)
  475.  
  476. Static Function aDelimit(cString,cDelimit)
  477. /* Split a semicolon (default) or otherwise delimited string into an Array */
  478. Local x,a := {}
  479. cDelimit := If(cDelimit=NIL,';',cDelimit)
  480. While (x := At(cDelimit,cString)) <>0
  481.     aAdd(a,SubStr(cString,1,x-1))
  482.     cString := SubStr(cString,x+Len(cDelimit))
  483. End
  484. aAdd(a,SubStr(cString,x+Len(cDelimit)))
  485. return (a)
  486.  
  487. * ==================== COLOR selection Routines ====================
  488.  
  489. Function ColorOn
  490. Return (isColor() .and. At("/BW",Upper(CommandLine()))=0)
  491.  
  492. Function NormColor
  493. Return (if(ColorOn(),'BG+/B,N/BG',''))
  494.  
  495. Function BoldColor
  496. Return (if(ColorOn(),'GR+/B,N/BG','w+/n,n/w'))
  497.  
  498. Function InvColor
  499. Return (if(ColorOn(),'n/bg','n/w'))
  500.  
  501. Function MsgColor
  502. Return (if(ColorOn(),'w+/BG,w+/n','n/w,w/m'))
  503.  
  504. Function ErrColor
  505. Return (If(ColorOn(),'w+/R,w+/n','n/w,w/n'))
  506.