home *** CD-ROM | disk | FTP | other *** search
/ Media Share 9 / MEDIASHARE_09.ISO / progmisc / dblib201.zip / MISC.PRG < prev    next >
Text File  |  1993-03-31  |  54KB  |  1,426 lines
  1. *-------------------------------------------------------------------------------
  2. *-- Program...: MISC.PRG
  3. *-- Programmer: Ken Mayer (CIS: 71333,1030)
  4. *-- Date......: 02/23/1993
  5. *-- Notes.....: These are the miscellaneous functions/procedures from the PROC
  6. *--             file that aren't as commonly used as the others. See README.TXT
  7. *--             for details on how to use this library file.
  8. *-------------------------------------------------------------------------------
  9.  
  10. FUNCTION PlayIt
  11. *-------------------------------------------------------------------------------
  12. *-- Programmer..: Mike Carlisle (A-T)
  13. *-- Date........: 01/21/1992
  14. *-- Notes.......: This function (from Technotes, issue??) will play a song
  15. *--               stored in a memory variable (array).
  16. *--               This is a two dimensional array, with the first dimension
  17. *--               defined being the # of notes, each note having two parts.
  18. *--               For a song with 12 notes, the declare statement is:
  19. *--                 DECLARE aSong[12,2]
  20. *--               aSong[1,1] is the pitch of the first note.
  21. *--               aSong[1,2] is the duration of the first note.
  22. *--               Pitches are defined from C below Middle C to B below Middle C.
  23. *--               These are from a "tempered" scale. Values can be raised an
  24. *--               octave by doubling the number, lowered by halving it.
  25. *--               Duration can be from 1 to 20.
  26. *--                           Note   Value
  27. *--                           C      261
  28. *--                           C#     277
  29. *--                           D      294
  30. *--                           D#     311
  31. *--                           E      329
  32. *--                           F      349
  33. *--                           F#     370
  34. *--                           G      392
  35. *--                           G#     415
  36. *--                           A      440
  37. *--                           A#     466
  38. *--                           B      494
  39. *-- Written for.: dBASE IV, 1.1
  40. *-- Rev. History: 01/21/1992 - Modified to allow use of parameter to choose
  41. *--               the song to be played. This alleviates the need for the
  42. *--               procedures SONG1 and SONG2 and the memfile created by them.
  43. *--               Two songs are provided (see below) ...
  44. *-- Calls.......: None
  45. *-- Called by...: Any
  46. *-- Usage.......: PlayIt(<nSong>)
  47. *-- Example.....: @5,10 say "Enter last name: " get lName valid required
  48. *--                      .not. empty(lName);
  49. *--                      error PlayIt(1)+"There must be a lastname ..."
  50. *--               Read
  51. *--                 && OR
  52. *--               ?? PlayIt(2)
  53. *-- Returns.....: Nul (or Beep on invalid parameter)
  54. *-- Parameters..: nSong = Song number. Programmer might consider adding to the
  55. *--                       list below for any songs added for documentation
  56. *--                       purposes ...
  57. *--                       VALID VALUES/SONGS:
  58. *--                         1  =  Dirge
  59. *--                         2  =  "Touchdown"
  60. *-------------------------------------------------------------------------------
  61.  
  62.     parameter nSong
  63.     private aSong, nCounter
  64.     
  65.     *-- check for valid type of parameter ... must be numeric ...
  66.     if .not. type("nSong") $ "NF"
  67.         return chr(7)
  68.     endif
  69.     
  70.     *-- get the integer value of nSong ... in case someone tries a "fast one"
  71.     nSong = int(nSong)
  72.     
  73.     *-- load song
  74.     do case
  75.         case nSong = 1  && dirge
  76.             declare aSong[12,2]          && 12 notes, 2 parts each
  77.             store 220     to aSong[1,1]  && pitch
  78.             store  10     to aSong[1,2]  && duration
  79.             store 220     to aSong[2,1]
  80.             store  10     to aSong[2,2]
  81.             store 220     to aSong[3,1]
  82.             store   2     to aSong[3,2]
  83.             store 220     to aSong[4,1]
  84.             store  10     to aSong[4,2]
  85.             store 261.63  to aSong[5,1]
  86.             store   7     to aSong[5,2]
  87.             store 246.94  to aSong[6,1]
  88.             store   2     to aSong[6,2]
  89.             store 246.94  to aSong[7,1]
  90.             store   5     to aSong[7,2]
  91.             store 220     to aSong[8,1]
  92.             store   5     to aSong[8,2]
  93.             store 220     to aSong[9,1]
  94.             store   5     to aSong[9,2]
  95.             store 205     to aSong[10,1]
  96.             store   5     to aSong[10,2]
  97.             store 220     to aSong[11,1]
  98.             store  15     to aSong[11,2]
  99.         case nSong = 2  && "touchdown"
  100.             declare aSong[7,2]           && 7 notes, 2 parts each
  101.             store 523.5   to aSong[1,1]  && pitch
  102.             store   2     to aSong[1,2]  && duration
  103.             store 587.33  to aSong[2,1]
  104.             store   2     to aSong[2,2]
  105.             store 659.29  to aSong[3,1]
  106.             store   2     to aSong[3,2]
  107.             store 783.99  to aSong[4,1]
  108.             store   7     to aSong[4,2]
  109.             store 659.29  to aSong[5,1]
  110.             store   2     to aSong[5,2]
  111.             store 783.99  to aSong[6,1]
  112.             store  10     to aSong[6,2]
  113.         otherwise                       && not song 1 or 2, return nothing
  114.             return chr(7)
  115.     endcase
  116.     
  117.     *-- playback
  118.     nCounter = 1
  119.     do while type("aSong[nCounter,1]") = "N"
  120.         set bell to aSong[nCounter,1],aSong[nCounter,2]
  121.         ?? chr(7) at col()
  122.         nCounter = nCounter + 1
  123.     enddo
  124.     set bell to  && return value to original
  125.  
  126. RETURN ""
  127. *-- EoF: PlayIt()
  128.  
  129. PROCEDURE PageEst
  130. *-------------------------------------------------------------------------------
  131. *-- Programmer..: Rachel Holmen (RAEHOLMEN)
  132. *-- Date........: 02/04/1992
  133. *-- Notes.......: This procedure estimates the number of pages needed for an 
  134. *--                output list. 
  135. *-- Written for.: dBASE IV, 1.1
  136. *-- Rev. History: 01/15/1992 - original procedure.
  137. *--               02/04/1992 - Ken Mayer - overhaul to allow the sending of
  138. *--               parameters for fields, rather than hard coding. Attempted to
  139. *--               make this a "black box" procedure.
  140. *-- Calls.......: CENTER               Procedure in PROC.PRG
  141. *--               SHADOW               Procedure in PROC.PRG
  142. *-- Called by...: Any
  143. *-- Usage.......: Do PageEst with <nCount>,"<cReport>",<nRecords>
  144. *-- Example.....: Use printers
  145. *--               Do PageEst with 0,"Printer for 'Hew' $ Brand",55
  146. *-- Returns.....: None
  147. *-- Parameters..: nCount   = record count for records to be printed ...
  148. *--                          if sent as "0", system will do a RECCOUNT() for you
  149. *--               cReport  = name of report, with any filters ... (FOR ...)
  150. *--               nRecords = number of records per page the report will handle.
  151. *--                          if sent as "0", system will assume 60 ...
  152. *-------------------------------------------------------------------------------
  153.  
  154.     parameters nCount,cReport,nRecords
  155.     private cReport2,nPos,nPage,cPage,cChoice,cCursor
  156.     
  157.     cReport2 = upper(cReport)
  158.     
  159.     *-- make sure we have a number of records to work with ...
  160.     if nCount = 0
  161.         if at("FOR",cReport2) > 0     && if a filter, extract the filter
  162.             npos = at("FOR",cReport2)  && so we can count records that match
  163.             cFilter = substr(cReport,Pos+3,len(cReport)-(npos-1))
  164.             count to nCount for &cFilter
  165.         else
  166.             nCount = reccount()
  167.         endif
  168.     endif
  169.     
  170.     if nRecords = 0
  171.         nRecords = 60
  172.     endif
  173.     
  174.     *-- calculate the number of pages for the report ...
  175.     store int(nCount/nRecords) to nPage
  176.     if mod(nCount,nRecords) > 45
  177.         store nPage+1 to nPage
  178.     else
  179.        store (nCount/nRecords) to nPage
  180.     endif
  181.     if nCount>0 .and. nCount < nRecords
  182.        store 1 to nPage
  183.     endif
  184.     
  185.     *-- deal with displaying info, and printing the report ...
  186.     save screen to sPrinter
  187.     activate screen            && in case there are other windows on screen ...
  188.     define window wPrinter from 8,15 to 15,65 double color rg+/gb,w/n,rg+/gb
  189.     do shadow with 8,15,15,65
  190.     activate window wPrinter
  191.     
  192.     *-- figure out how much to tell the user ...
  193.     if mod(nCount,nRecords) > 19 .and. mod(nCount,nRecords) < 46
  194.        store ltrim(str(nPage))+" and a half pages.)" to cPage
  195.     else
  196.        store ltrim(str(nPage))+" pages.)" to cPage
  197.     endif
  198.     
  199.     if nPage = 1
  200.        store "one page.)" to cPage
  201.     endif
  202.     
  203.     *-- display info ...
  204.     do center with 1,50,"",;
  205.         "There are "+ltrim(str(nCount))+" records."
  206.     do center with 2,50,"","(That's approximately "+cPage
  207.     
  208.     *-- ask if they want to generate the report?
  209.     store space(1) to cChoice
  210.     @4,8 say "Do you want to print the list? " get cChoice picture "!" ;
  211.         valid required cChoice $ "YN";
  212.         error chr(7)+"Enter 'Y' or 'N'!"
  213.     read
  214.     
  215.     *-- if yes, do it ...
  216.     if cChoice = "Y"
  217.         clear   && just this window ...
  218.         do center with 2,50,"","Align paper in your printer."
  219.         do center with 3,50,"","Press any key to continue ..."
  220.         x=inkey(0)
  221.         clear
  222.         do center with 2,50,"","... Printing ... do not disturb ..."
  223.         cCursor = set("CURSOR")
  224.         set cursor off
  225.         set console off
  226.         report form &cReport to print
  227.         set console on
  228.         set cursor &cCursor
  229.     endif
  230.     
  231.     *-- cleanup
  232.     deactivate window wPrinter
  233.     release window wPrinter
  234.     restore screen from sPrinter
  235.     release screen sPrinter
  236.  
  237. RETURN
  238. *-- EoP: PageEst
  239.  
  240. FUNCTION Permutes
  241. *-------------------------------------------------------------------------------
  242. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  243. *-- Date........: 03/01/1992
  244. *-- Notes.......: Permutations of nNum items taken Nhowmany at a time
  245. *--               That is, the number of possible arrangements, as
  246. *--               the different ways a president, V.P. and sec'y may
  247. *--               be chosen from a club of 10 members
  248. *-- Written for.: dBASE IV, 1.1
  249. *-- Rev. History: 03/01/1992 -- Original Release
  250. *-- Calls.......: None
  251. *-- Called by...: Any
  252. *-- Usage.......: Permutes(<nNum>,<nHowMany>)
  253. *-- Example.....: ?Permutes(10,3)
  254. *-- Returns.....: Numeric
  255. *-- Parameters..: nNum     = number of items in the entire set
  256. *--               nHowMany = number to be used at once
  257. *-------------------------------------------------------------------------------
  258.  
  259.     parameters nNum, nHowmany
  260.     private nResult, nCounter
  261.     store 1 to nResult, nCounter
  262.     do while nCounter <= nHowmany
  263.       nResult = nResult * ( nNum + 1 - nCounter )
  264.       nCounter = nCounter + 1
  265.     enddo
  266.     
  267. RETURN nResult
  268. *-- EoF: Permutes()
  269.  
  270. FUNCTION Combos
  271. *-------------------------------------------------------------------------------
  272. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  273. *-- Date........: 03/01/1992
  274. *-- Notes.......: Combinations, similar to Permutations
  275. *--               Combinations treat "1, 3" as the same as
  276. *--               "3, 1", unlike permutations.  This gives the
  277. *--               games needed for a round robin and helps with
  278. *--               figuring odds of most state lotteries.
  279. *-- Written for.: dBASE IV, 1.1
  280. *-- Rev. History: 03/01/1992 -- Original Release
  281. *-- Calls.......: None
  282. *-- Called by...: Any
  283. *-- Usage.......: Combos(<nNum>,<nHowMany>)
  284. *-- Example.....: ?Combos(10,2)
  285. *-- Returns.....: Numeric
  286. *-- Parameters..: nNum     = number of items in the entire set
  287. *--               nHowMany = number to be used at once
  288. *-------------------------------------------------------------------------------
  289.  
  290.     parameters nNum, nHowmany
  291.     private nResult, nCounter
  292.     store 1 to nResult, nCounter
  293.     do while nCounter <= nHowmany
  294.       nResult = nResult * ( nNum + 1 - nCounter ) / nCounter
  295.       nCounter = nCounter + 1
  296.     enddo
  297.     
  298. RETURN nResult
  299. *-- Combos()
  300.                                                           
  301. FUNCTION BinLoad
  302. *-------------------------------------------------------------------------------
  303. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  304. *-- Date........: 03/01/1992
  305. *-- Notes.......: Function to manage .bin files
  306. *--               A call to this function results in the following actions:
  307. *--          
  308. *--               If the name of a binary module alone is given as the argument,
  309. *--               the module is loaded if necessary, and .T. is returned.
  310. *--               If the file cannot be found, returns .F.
  311. *--               An error occurring during the load will cause a dBASE error.
  312. *--
  313. *--               If the argument "" is given, RELEASES all loaded modules and
  314. *--               returns .T.
  315. *--
  316. *--               If the argument contains the name of a loaded binary file
  317. *--               and "/R", RELEASEs that file only and returns .T.  If the
  318. *--               file is not listed in "gc_bins_in", returns .F.
  319. *--
  320. *--               This function uses the public variable "gc_bins_in".  It
  321. *--               keeps track of the modules loaded by changing the contents
  322. *--               of that variable.  If modules are loaded or released without
  323. *--               the use of this function, the variable will contain an
  324. *--               inaccurate list of the modules loaded and problems will
  325. *--               almost surely occur if this function is used later.
  326. *--
  327. *--               If more than 16 binary modules are requested over time through
  328. *--               this function, the one that was named least recently in a call
  329. *--               to load it by this function is released to make room for the
  330. *--               new one.  This will not necessarily be the module last used,
  331. *--               unless care is taken to use this function to "reload" the
  332. *--               .bin before each call.
  333. *--
  334. *--               Suggested syntax, to call the binary routine "Smedley.bin" 
  335. *--               which takes and returns two arguments:
  336. *-- 
  337. *--               IF binload( "Smedley" )
  338. *--                 CALL Smedley WITH Arg1, Arg2
  339. *--               ELSE
  340. *--                 ? "binary file not available"
  341. *--               ENDIF
  342. *-- Written for.: dBASE IV, 1.1
  343. *-- Rev. History: 03/01/1992 -- Original Release
  344. *-- Calls.......: ATCOUNT()            Function in MISC.PRG
  345. *-- Called by...: Any
  346. *-- Usage.......: BinLoad(<cBinName>)
  347. *-- Example.....: ?BinLoad("Smedley")
  348. *-- Returns.....: Logical (.T. if successful )
  349. *-- Parameters..: cBinName = name of bin file to load ...
  350. *-------------------------------------------------------------------------------
  351.  
  352.     parameters cBinname
  353.    private cBin, nPlace, nTemp, lResult
  354.     cBin = ltrim( trim( upper( cBinname ) ) )
  355.     if type( "gc_bins_in" ) = "U"
  356.        public gc_bins_in
  357.        gc_bins_in = ""
  358.     endif
  359.    lResult = .T.
  360.    do case
  361.        case "" = cBin
  362.            do while "" # gc_bins_in
  363.               nPlace = at( "*", gc_bins_in )
  364.               cBin = left( gc_bins_in, nPlace - 1 )
  365.               gc_bins_in = substr( gc_bins_in, nPlace + 1 )
  366.               release module &cBin
  367.            enddo
  368.            release gc_bins_in
  369.        case "/R" $ cBinname
  370.            cBin = trim( left( cBin, at( cBin, "/" ) - 1 ) )
  371.           if "." $ cBin
  372.              cBin = left( cBin, at( ".", cBin ) - 1 )
  373.           endif
  374.           nPlace = at( cBin, gc_bins_in )
  375.            if nPlace = 0
  376.              lResult = .F.
  377.           else
  378.              gc_bins_in = substr( gc_bins_in, nPlace + 1 )
  379.              release module &cBin
  380.           endif
  381.        otherwise
  382.           if "." $ cBin
  383.              cBin = left( cBin, at( ".", cBin ) - 1 )
  384.           endif
  385.           if .not. file( cBin )
  386.              lResult = .F.
  387.           else
  388.              if atcount( "*", gc_bins_in ) > 15
  389.                 nPlace = at( "*", gc_bins_in )
  390.                 cTemp = left( gc_bins_in, nPlace - 1 )
  391.                 release module &cTemp
  392.                 gc_bins_in = substr( gc_bins_in, nPlace + 1)
  393.              endif
  394.              load &cBin
  395.              nPlace = at( cBin, gc_bins_in )
  396.              if Place > 0
  397.                 gc_bins_in = stuff( gc_bins_in, nPlace, len( cBin ) + 1, "" )
  398.              endif
  399.              gc_bins_in = gc_bins_in + cBin + "*"
  400.           endif
  401.    endcase
  402.  
  403. RETURN lResult
  404. *-- EoF: BinLoad()
  405.  
  406. FUNCTION DialUp
  407. *-----------------------------------------------------------------------
  408. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  409. *-- Date........: 06/17/1992
  410. *-- Notes.......: Dial the supplied telephone number.  Returns .F. for error.
  411. *--               This is not a full communications routine.  It is designed
  412. *--               to be used to place voice telephone calls, with the user
  413. *--               picking up the handset after using this function to dial.
  414. *--
  415. *--               This will work only with a modem using the standard Hayes
  416. *--               commands, and only if the port has already been set to the
  417. *--               desired baud rate, etc., by the DOS MODE command or 
  418. *--               otherwise.  If the port and dialing method are not constant
  419. *--               for the application, rewrite the function to accept them as
  420. *--               additional parameters.
  421. *--
  422. *-- Written for.: dBASE IV, 1.1, 1.5
  423. *-- Rev. History: 03/01/1992 - original function.
  424. *--               04/01/1992 - Jay Parsons - modified for Version 1.5.
  425. *--               04/03/1992 - Jay Parsons - ferror() call added.
  426. *--               06/17/1992 - Jay Parsons - 1.1 version changed to use
  427. *--                              SET PRINTER TO Device rather than .bin.
  428. *-- Calls       : Strpbrk()            Function in MISC.PRG
  429. *-- Called by...: Any
  430. *-- Usage.......: DialUp(<cPhoneNo>)
  431. *-- Example.....: x = DialUp( "555-1212" )
  432. *-- Returns.....: Logical (connect made or not)
  433. *-- Parameters..: cPhoneNo = Phone number to dial ...
  434. *-- Side effects: When used for versions before 1.1, sets the printer to
  435. *--             : a COM port and does not reset it.
  436. *-----------------------------------------------------------------------
  437.  
  438.    parameters cPhoneNo
  439.    private cNumber, cPort, cDialtype, cCallarg, xTemp, nHandle,;
  440.               cString, lResult
  441.    cPort = "Com2"          && specify Com1 or Com2 as required 
  442.    cDialtype = "Tone"      && specify Tone or Pulse ( rotary ) dialing
  443.    cNumber = cPhoneno
  444.    if type( "cPhoneno" ) $ "NF"
  445.       cNumber = ltrim( str( cPhoneno ) )
  446.    else
  447.       do while .t.
  448.          xTemp = Strpbrk( cNumber, " ()-" )
  449.          if xTemp = 0
  450.             exit
  451.          endif
  452.          cNumber = stuff( cNumber, xTemp, 1, "" )
  453.       enddo
  454.    endif
  455.    cString = "ATD" + upper( left( cDialtype, 1 ) ) + cNumber + chr(13 )
  456.    if val( substr( version(), 9, 5 ) ) < 1.5
  457.       SET PRINTER TO &cPort
  458.       ??? Cstring
  459.       lResult = .T.
  460.    else
  461.       nHandle = fopen( cPort, "w" )
  462.       if ferror() # 0
  463.          RETURN .F.
  464.       endif
  465.       lResult = ( fwrite( nHandle, cString ) = len( cString ))
  466.       xTemp = fclose( nHandle )
  467.    endif
  468.  
  469. RETURN lResult
  470. *-- EoF: Dialup()
  471.  
  472. FUNCTION CurrPort
  473. *-------------------------------------------------------------------------------
  474. *-- Programmer..: David P. Brown (RHEEM)
  475. *-- Date........: 03/22/1992
  476. *-- Notes.......: This procedure gets the current SET PRINTER TO information.
  477. *--               Will return a port or a filename if set to a file. This also
  478. *--               requires a DBF file called CURRPRT.DBF, with an MDX tag
  479. *--               set on the only field CURRPRT, which is a character field
  480. *--               of 80 characters.
  481. *--
  482. *--               Structure for database: CURRPRT.DBF
  483. *--               Number of data records:       0
  484. *--               Date of last update   : 03/22/92
  485. *--               Field  Field Name  Type       Width    Dec    Index
  486. *--                   1  CURRPRT     Character     80               Y
  487. *--               ** Total **                      81
  488. *--
  489. *-- Written for.: dBASE IV, 1.1
  490. *-- Rev. History: 03/18/1992 - original function.
  491. *--               03/18/1992 -- Ken Mayer (CIS: 71333,1030) to clean it up a bit, and
  492. *--               make it a function (not requiring the public memvar that
  493. *--               was originally required).
  494. *--               03/21/1992 -- David P. Brown (RHEEM) found bug while
  495. *--               selecting a previous work area (stored on cDBF).  Changed
  496. *--               'select cDBF' to 'select (cDBF)'.
  497. *--               03/22/1992 -- David P. Brown (RHEEM) final revision.  Added
  498. *--               check for no available work areas.  If none is available
  499. *--               then the program returns a null.
  500. *-- Calls.......: None
  501. *-- Called by...: Any
  502. *-- Usage.......: CurrPort()
  503. *-- Example.....: ? CurrPort()
  504. *-- Returns.....: the current port, as a character value
  505. *--               Port:   LPTx:, COMx:, PRN:
  506. *--               File:   Filename (with or without drive and path, depends
  507. *--                       on how the user entered it in the SET command)
  508. *--               Other:  Null (no work area available)
  509. *-- Parameters..: None
  510. *-------------------------------------------------------------------------------
  511.  
  512.    private cSafety, cConsole, cDBF, cPort
  513.  
  514.    *-- Check for available work area (safety check)
  515.    if select() = 0
  516.       return ""
  517.    endif
  518.    *-- Setup
  519.    cSafety = set("SAFETY")
  520.    set safety off
  521.    *-- so user can't see what's going on
  522.    cConsole = set("CONSOLE")
  523.    set console off
  524.    
  525.    if file("CURRPRT$.OUT")  && if this file exists
  526.       erase CURRPRT$.OUT    &&   delete it, so we can write on it
  527.    endif
  528.    
  529.    cDBF = alias()           && get current work area, so we can return ...
  530.    
  531.    *-- Get current printer
  532.    *-- note that we are not using 'Set Printer to file ...' due to the
  533.    *-- fact that this will change the info that the 'LIST STAT' command
  534.    *-- issues ...
  535.    set alternate to currprt$.out  && direct screen input to file
  536.    set alternate on
  537.    list status                    && returns environment information
  538.    set alternate off              && turn off 'capture'
  539.    close alternate                && close file 'currprt$.out'
  540.  
  541.    select select()                && grab next available work area ...
  542.    
  543.    use currprt order currprt excl && open database called CURRPRT
  544.    zap                            && clean out old copy of this file
  545.    
  546.    append from currprt$.out type sdf
  547.                                   && import the data for manipulation
  548.    
  549.    seek "Print"
  550.    *-- This is setup to do an indexed search, since the printer information
  551.    *-- will not always be on the same line. If it were, we could issue a
  552.    *-- 'GO <n>' command, which would speed up the routine. Somewhere on
  553.    *-- line 8 to 12 (or record) is 'Print destination: <port/file>'. The
  554.    *-- seek looks for the first word. The command below trims out the
  555.    *-- first part of the line, and extra spaces as well. This will
  556.    *-- return the information after the colon.
  557.    cPort = upper(trim(right(currprt,60))) && always in upper case
  558.    
  559.    *-- clean up
  560.    use
  561.    
  562.    if len(trim(cDBF)) > 0
  563.       select (cDBF)
  564.    else
  565.       select 1
  566.    endif
  567.    
  568.    *-- erase this file
  569.    erase currprt$.out 
  570.    
  571.    *-- return safety and console to previous states ...
  572.    set safety &cSafety
  573.    set console &cConsole
  574.    
  575. RETURN cPort
  576. *-- EoF: CurrPort()
  577.  
  578. FUNCTION FileLock
  579. *-------------------------------------------------------------------------------
  580. *-- Programmer..: Miriam Liskin
  581. *-- Date........: 04/27/1992
  582. *-- Notes.......: Taken from Miriam Liskin's dBASE IV, 1.1 Programming Book.
  583. *--               This routine modified by Ken Mayer to handle slightly
  584. *--               fancier processing ...
  585. *-- Written for.: dBASE IV, 1.1
  586. *-- Rev. History: 04/27/1992 -- Modified by Ken Mayer to give cleaner windows
  587. *--               and such.
  588. *-- Calls.......: CENTER               Procedure in PROC.PRG
  589. *--               SHADOW               Procedure in PROC.PRG
  590. *--               COLORBRK()           Function in PROC.PRG
  591. *-- Called by...: Any
  592. *-- Usage.......: FileLock("<cColor>") 
  593. *-- Example.....: if FileLock("&cl_Wind1")
  594. *--                  *-- pack/reindex/whatever you need to do to database
  595. *--               else
  596. *--                  *-- do whatever processing necessary if file not
  597. *--                  *-- available for locking at this time
  598. *--               endif
  599. *-- Returns.....: Logical (.t./.f.)
  600. *-- Parameters..: cColor = Color combination for window ...
  601. *-------------------------------------------------------------------------------
  602.  
  603.     parameters cColor
  604.     private nCount,lLock,x,cCurNorm,cCurBox,cTempCol
  605.     
  606.     *-- deal with dBASE IV standard errors -- we don't want program bombing
  607.     on error ??
  608.     
  609.     *-- deal with screen stuff ...
  610.     *-- get it started ...
  611.     nCount = 1   && start at 1
  612.     lLock = .t.  && assume true
  613.     
  614.     *-- try 100 times
  615.     do while nCount <= 100 .and. .not. flock() .and. inkey() = 0
  616.         nCount = nCount + 1
  617.     enddo
  618.     
  619.     *-- if we can't lock the file, let the user know ...
  620.     if .not. flock()
  621.         lLock = .f.
  622.         save screen to sLock
  623.         *-- save colors
  624.         cCurNorm = colorof("NORMAL")
  625.         cCurBox  = colorof("BOX")
  626.         *-- set new colors
  627.         cTempCol = colorbrk(cColor,1)
  628.         set color of normal to &cTempCol
  629.         cTempCol = colorbrk(cColor,3)
  630.         set color of box to &cTempCol
  631.         *-- define window, display message
  632.         activate screen
  633.         define window wLock from 10,15 to 18,65 double
  634.         do shadow with 10,15,18,65
  635.         activate window sLock
  636.         do center with 1,50,"","The file cannot be locked at this time"
  637.         do center with 2,50,"","Please try again."
  638.         x = inkey(0)
  639.         *-- cleanup
  640.         deactivate window wLock
  641.         release window wLock
  642.         restore screen from sLock
  643.         release screen sLock
  644.         *-- reset colors
  645.         set color of normal to &cCurNorm
  646.         set color of box    to &cCurBox
  647.     endif
  648.     
  649.     *-- clean up screen, etc.
  650.     on error
  651.     
  652. RETURN lLock
  653. *-- EoF: FileLock()
  654.  
  655. FUNCTION RecLock
  656. *-------------------------------------------------------------------------------
  657. *-- Programmer..: Miriam Liskin
  658. *-- Date........: 04/27/1992
  659. *-- Notes.......: Taken from Miriam Liskin's dBASE IV, 1.1 Programming Book.
  660. *--               This function attempts to lock current record in active
  661. *--               database. 
  662. *-- Written for.: dBASE IV, 1.1
  663. *-- Rev. History: 04/27/1992 -- Modified by Ken Mayer to give cleaner windows
  664. *--               and such.
  665. *-- Calls.......: SHADOW               Procedure in PROC.PRG
  666. *--               COLORBRK()           Function in PROC.PRG
  667. *-- Called by...: Any
  668. *-- Usage.......: RecLock("<cColor>") 
  669. *-- Example.....: if RecLock("&cl_Wind1")
  670. *--                  *-- process record
  671. *--               else
  672. *--                  *-- return to menu, or whatever processing your routine
  673. *--                  *-- does at this point
  674. *--               endif
  675. *-- Returns.....: Logical (.t./.f.)
  676. *-- Parameters..: cColor = Color combination for window ...
  677. *-------------------------------------------------------------------------------
  678.  
  679.     parameters cColor
  680.     private nCount, lLock, cRetry, cCurNorm, cCurBox, cTempCol
  681.     
  682.     *-- deal with dBASE IV standard errors -- we don't want program bombing
  683.     on error ??
  684.     
  685.     *-- deal with screen
  686.     *-- start trying -- we will give the user the option to exit -- each time
  687.     *-- they unsuccessfully lock the record.
  688.     lLock = .t.   && assume true
  689.     do while .t.  && main loop
  690.         nCount = 1 && initialize each time we try ...
  691.         
  692.         *-- effectively a time-delay loop ...
  693.         do while nCount <= 100 .and. .not. rLock() .and. inkey() = 0
  694.             nCount = nCount + 1
  695.         enddo
  696.         
  697.         *-- if we CAN lock it, we're done, get outta here ...
  698.         if rlock()
  699.             lLock = .t.
  700.             exit
  701.         
  702.         else
  703.         
  704.             *-- otherwise, let the user know we couldn't do it, and ask if
  705.             *-- they want to try again ...
  706.             save screen to sLock
  707.             *-- save colors
  708.             cCurNorm = colorof("NORMAL")
  709.             cCurBox  = colorof("BOX")
  710.             *-- set new colors
  711.             cTempCol = colorbrk(cColor,1)
  712.             set color of normal to &cTempCol
  713.             cTempCol = colorbrk(cColor,3)
  714.             set color of box to &cTempCol
  715.             *-- define window ...
  716.             activate screen
  717.             define window wLock from 10,15 to 18,65 double
  718.             do shadow with 10,15,18,65
  719.             activate window wLock
  720.             lLock = .f.
  721.             cRetry = 'N'
  722.             @1,3 say "This record is being updated at another"
  723.             @2,3 say "workstation. You can try again now,"
  724.             @3,3 say "to access the record, or return to it"
  725.             @4,3 say "later."
  726.             @6,3 say "Do you want to try again now? " get cRetry;
  727.                 picture "!";
  728.                 valid required cRetry $ "YN";
  729.                 error chr(7)+"Enter 'Y' or 'N'"
  730.             read
  731.             *-- cleanup
  732.             deactivate window wLock
  733.             release window wLock
  734.             restore screen from sLock
  735.             release screen sLock
  736.             *-- reset colors
  737.             set color of normal to &cCurNorm
  738.             set color of box    to &cCurBox
  739.             
  740.             if cRetry = "N"
  741.                 exit
  742.             endif  && cRetry = "N"
  743.             
  744.         endif  && rLock()
  745.         
  746.     enddo  && end of main loop
  747.     
  748.     *-- cleanup
  749.     on error
  750.  
  751. RETURN lLock
  752. *-- EoF: RecLock()
  753.  
  754. FUNCTION UserId
  755. *-------------------------------------------------------------------------------
  756. *-- Programmer..: Angus Scott-Fleming (ANGUSSF)
  757. *-- Date........: 04/20/1992
  758. *-- Notes.......: Returns log-in USER ID regardless of Network Type
  759. *--               ***********************************************************
  760. *--               ** IF DBASE IV VERSION IS < 1.5 THIS REQUIRES USERID.BIN **
  761. *--               ***********************************************************
  762. *-- Written for.: dBASE IV v1.5, will work in 1.1, if you use EMPTY()
  763. *-- Rev. History: 10/27/1992 -- Ken Mayer cleaned up a tad ...
  764. *-- Calls.......: None if version 1.5, EMPTY() if version 1.1
  765. *-- Called by...: Any
  766. *-- Usage.......: UserID()
  767. *-- Example.....: ? UserID()
  768. *-- Returns.....: Character String (up to 8 characters)
  769. *-- Parameters..: None
  770. *-------------------------------------------------------------------------------
  771.  
  772.     private cTemp
  773.     if network()
  774.         if .not. isblank(getenv("USERID"))
  775.             *-- if you're working on a Lantastic net, USERID will lock the
  776.             *-- system up. Use a DOS environment variable USERID instead.
  777.             *-- This also works as a temporary override for testing access levels.
  778.             cTemp = left(getenv("USERID"),8)
  779.         else
  780.             if val(right(version(),3)) => 1.5   && version 1.5 of dBASE IV
  781.                 cTemp = id()
  782.             else
  783.                 cTemp = space(48)
  784.                 if file("USERID.BIN")
  785.                     load userid
  786.                     call userid with cTemp
  787.                     release module userid
  788.                 endif && file("USERID.BIN")
  789.             endif && val(right...)
  790.         endif && .not. isblank(getenv ...
  791.     else
  792.         cTemp = ""
  793.     endif  && network()
  794.  
  795. RETURN left(cTemp,8)  && which MIGHT be empty ...
  796. *-- EoF: UserID
  797.  
  798. PROCEDURE DosShell
  799. *-------------------------------------------------------------------------------
  800. *-- Programmer..: Bowen Moursund (CIS: 76566,1405)
  801. *-- Date........: 06/10/1992
  802. *-- Notes.......: Swaps out dBASE from memory, loads a DOS shell
  803. *-- Written for.: dBASE IV v1.5
  804. *-- Rev. History: 06/10/1992 -- Original Release
  805. *-- Calls.......: TempName()           Function in FILES.PRG
  806. *-- Called by...: Any
  807. *-- Usage.......: do DosShell with <cAppName>
  808. *-- Example.....: do DosShell with "MyApp"
  809. *-- Parameters..: cAppName - the name of the application
  810. *-------------------------------------------------------------------------------
  811.  
  812.     parameter cAppName
  813.      private cDir, lCursOff, cBatFile, nFH, nResult
  814.     cAppName = iif(pcount() = 0, "the application", cAppName)
  815.     private all
  816.     cDir = set("directory")
  817.     lCursOff = ( set("cursor") = "OFF" )
  818.     cBatFile = tempname("bat") + ".bat"
  819.     nFH = fcreate(cBatFile)
  820.     if nFH > 0
  821.         nBytes = fputs(nFH,"echo off")
  822.         nBytes = fputs(nFH,"cls")
  823.         nBytes = fputs(nFH,"echo " + chr(255))  && echo a blank line
  824.         nBytes = fputs(nFH,"echo NOTE: Enter EXIT to resume " + cAppName + ".")
  825.         nBytes = fwrite(nFH,getenv("comspec"))
  826.         null = fclose(nFH)
  827.         set cursor on
  828.         nResult = run(.f., cBatFile, .t.)
  829.         if nResult # 0
  830.             run &cBatFile
  831.         endif
  832.         erase (cBatFile)
  833.     else
  834.         cComSpec = getenv("comspec")
  835.         set cursor on
  836.         run &cComSpec.
  837.     endif
  838.     if lCursOff
  839.         set cursor off
  840.     endif
  841.     set directory to &cDir
  842.  
  843. RETURN
  844. *-- EoP: DosShell
  845.  
  846. FUNCTION IsDisk
  847. *-------------------------------------------------------------------------------
  848. *-- Programmer...: Ken Mayer (CIS: 71333,1030)
  849. *-- Date.........: 07/13/1992
  850. *-- Notes........: This routine is useful to check a drive for a valid disk in
  851. *--                in it (Valid means it is in the drive, with the door closed,
  852. *--                and is formatted ...). 
  853. *--                ***********************
  854. *--                ** REQUIRES DISK.BIN **
  855. *--                ***********************
  856. *-- Written for.: dBASE IV, 1.5
  857. *-- Rev. History: 07/13/1992 -- Original Release
  858. *-- Called by...: None
  859. *-- Calls.......: CENTER               Procedure in PROC.PRG
  860. *--               SHADOW               Procedure in PROC.PRG
  861. *-- Usage.......: IsDisk(<cDrive>,<cMessCol>,<cErrCol>)
  862. *-- Example.....: IsDisk("cDrive","rg+/gb","rg+/r")
  863. *-- Returns.....: Logical
  864. *-- Parameters..: cDrive   = drive name -- single letter, no colon (i.e., "A")
  865. *--               cMessCol = color for message bonX
  866. *--               cErrCol  = color for error message
  867. *-------------------------------------------------------------------------------
  868.  
  869.     parameters cDrive, cMessCol, cErrCol
  870.  
  871.     private nX, cDrive2
  872.     
  873.     *-- deal with message window
  874.     save screen to sDisk
  875.     activate screen
  876.     define window wDisk from 9,15 to 12,65 double color &cMessCol,,&cMessCol
  877.     do shadow with 9,15,12,65
  878.     activate window wDisk
  879.     *-- display message ...
  880.     do center with 0,50,"&cMessCol",;
  881.         "Place disk in drive "+cDrive+": and close drive door."
  882.     do center with 1,50,"&cMessCol",;
  883.         "Press any key when ready ..."
  884.     set cursor off
  885.     nX=inkey(0)
  886.     set cursor on
  887.     deactivate window wDisk
  888.     restore screen from sDisk
  889.  
  890.     *-- check for a valid drive. This uses the BIN file: DISK.BIN to do so.
  891.     load disk                 && load the BIN file
  892.     cDrive2 = cDrive          && save the current setting in case there's a prob.
  893.     call disk with cDrive2    && check to see if it's valid
  894.     activate screen
  895.     define window wDisk from 7,10 to 14,70 double color &cErrCol,,&cErrCol
  896.     do while cDrive2 = 'X'    && perform loop if value of cDrive2 is 'X' (error)
  897.         do shadow with 7,10,14,70
  898.         activate window wDisk
  899.         do center with 0,60,"&cErrCol",;
  900.             "** DRIVE ERROR **"
  901.         do center with 2,60,"&cErrCol",;
  902.             "Check to make sure a valid (formatted) disk is in drive,"
  903.         do center with 3,60,"&cErrCol",;
  904.             "and that the drive door is closed properly."
  905.         do center with 5,60,"&cErrCol",;
  906.             "Press <Esc> to exit, any other key to continue ..."
  907.         set cursor off
  908.         nX=inkey(0)
  909.         set cursor on
  910.         deactivate window wDisk
  911.         restore screen from sDisk
  912.         if nX = 27                 && user pressed <Esc>
  913.             release module disk
  914.             release window wDisk
  915.             release screen sDisk
  916.             RETURN .F.
  917.         endif
  918.         cDrive2 = cDrive          && reset cDrive2 from original
  919.         call disk with cDrive2    && check for validity again ...
  920.     enddo
  921.  
  922.     *-- cleanup
  923.     release module Disk          && remove module from RAM so we can continue
  924.     restore screen from sDisk
  925.     release screen sDisk
  926.     release window wDisk
  927.  
  928. RETURN .t.
  929. *-- EoF: IsDisk()
  930.  
  931. *-------------------------------------------------------------------------------
  932. *-- The following are here as a courtesy ...
  933. *-------------------------------------------------------------------------------
  934.  
  935. FUNCTION AtCount
  936. *-------------------------------------------------------------------------------
  937. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  938. *-- Date........: 03/01/1992
  939. *-- Notes.......: returns the number of times FindString is found in Bigstring
  940. *-- Written for.: dBASE IV
  941. *-- Rev. History: 03/01/1992 -- Original Release
  942. *-- Calls.......: None
  943. *-- Called by...: Any
  944. *-- Usage.......: AtCount("<cFindStr>","<cBigStr>")
  945. *-- Example.....: ? AtCount("Test","This is a Test string, with Test data")
  946. *-- Returns.....: Numeric value
  947. *-- Parameters..: cFindStr = string to find in cBigStr
  948. *--               cBigStr  = string to look in
  949. *-------------------------------------------------------------------------------
  950.  
  951.     parameters cFindstr, cBigstr
  952.     private cTarget, nCount
  953.     
  954.     cTarget = cBigstr
  955.     nCount = 0
  956.     
  957.     do while .t.
  958.         if at( cFindStr,cTarget ) > 0
  959.             nCount = nCount + 1
  960.             cTarget = substr( cTarget, at( cFindstr, cTarget ) + 1 )
  961.         else
  962.          exit
  963.         endif
  964.     enddo
  965.     
  966. RETURN nCount
  967. *-- EoF: AtCount()
  968.     
  969. FUNCTION Dec2Hex
  970. *-------------------------------------------------------------------------------
  971. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  972. *-- Date........: 03/01/1992
  973. *-- Notes.......: Converts an integral number ( in decimal notation)
  974. *--               to a hexadecimal string
  975. *-- Written for.: dBASE IV, 1.1
  976. *-- Rev. History: 03/01/1992 -- Original Release
  977. *-- Calls.......: None
  978. *-- Called by...: Any
  979. *-- Usage.......: Dec2Hex(<nDecimal>)
  980. *-- Example.....: ? Dec2Hex( 118 )
  981. *-- Returns.....: Character = Hexadecimal equivalent ( "F6" in example )
  982. *-- Parameters..: nDecimal = number to convert
  983. *-------------------------------------------------------------------------------
  984.     
  985.     parameters nDecimal
  986.     private nD, cH
  987.     nD = int( nDecimal )
  988.     cH= ""
  989.     do while nD > 0
  990.       cH = substr( "0123456789ABCDEF", mod( nD, 16 ) + 1 , 1 ) + cH
  991.       nD = int( nD / 16 )
  992.     enddo
  993.     
  994. RETURN iif( "" = cH, "0", cH )
  995. *-- Eof: Dec2Hex()
  996.  
  997. FUNCTION StrPBrk
  998. *-------------------------------------------------------------------------------
  999. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  1000. *-- Date........: 03/01/1992
  1001. *-- Notes.......: Search string for first occurrence of any of the
  1002. *--               characters in charset.  Returns its position as
  1003. *--               with at().  Contrary to ANSI.C definition, returns
  1004. *--               0 if none of characters is found.
  1005. *-- Written for.: dBASE IV
  1006. *-- Rev. History: 03/01/1992 -- Original Release
  1007. *-- Calls.......: None
  1008. *-- Called by...: Any
  1009. *-- Usage.......: StrPBrk("<cCharSet>","<cBigStr>")
  1010. *-- Example.....: ? StrPBrk("Tt","This is a Test string, with Test data")
  1011. *-- Returns.....: Numeric value
  1012. *-- Parameters..: cCharSet = characters to look for in cBigStr
  1013. *--               cBigStr  = string to look in
  1014. *-------------------------------------------------------------------------------
  1015.  
  1016.     parameters cCharset, cBigstring
  1017.     private nPos, nLooklen
  1018.     nPos = 0
  1019.     nLooklen = len( cBigstring )
  1020.     do while nPos < nLooklen
  1021.       nPos = nPos + 1
  1022.         if at( substr( cBigstring, nPos, 1 ), cCharset ) > 0
  1023.          exit
  1024.        endif
  1025.     enddo
  1026.     
  1027. RETURN iif(nPos=nLookLen,0,nPos)
  1028. *-- EoF: StrPBrk()
  1029.  
  1030. PROCEDURE BlankIt
  1031. *-------------------------------------------------------------------------------
  1032. *-- Programmer..: Bill Garrison (BILLG), Roger Breckenridge 
  1033. *-- Date........: 01/08/1993
  1034. *-- Notes.......: Screen Saver from within dbase - uploaded to Public Domain
  1035. *-- Written for.: dBase IV 1.5  (probably work with 1.1 though)
  1036. *-- Rev. History: Original clock prg was from Michael Irwin, who I believe
  1037. *--             : expanded on from source unknown.
  1038. *--             : 10/29/1992: Modified original program received at
  1039. *--             :             Ashton-Tate Seminar a year or so ago.
  1040. *--             :             Fine tuned it and added moving window feature.
  1041. *--             : 11/02/1992: Modified -- Ken Mayer -- dUFLP and added
  1042. *--             :             Jay's RECOLOR routine, as SET COLOR TO
  1043. *--                           does not reset properly.
  1044. *--               01/08/1992: Fixed ON KEY reset, which was to "Blanker", not
  1045. *--                           "Blankit".
  1046. *-- Calls.......: CLOCKIT              Procedure in MISC.PRG
  1047. *--             : RECOLOR              Procedure in PROC.PRG
  1048. *-- Called by...: Any
  1049. *-- Usage.......: Do BLANKIT
  1050. *-- Example.....: ON KEY LABEL Alt-B DO BlankIt
  1051. *-- Returns.....: None
  1052. *-- Parameters..: None
  1053. *-------------------------------------------------------------------------------
  1054.     
  1055.    on key label alt-B           && turn off key label that called this prg
  1056.    save screen to sBlanker
  1057.    private aTimeAll,nTX,nTY,cSpace,cTop,cBottom,cSide,lMary,nSec8,;
  1058.            clSet2,clSet3,cTalk,cCursor
  1059.     
  1060.     *-- save settings
  1061.    cCursor= set("CURSOR")
  1062.    cTalk  = set("TALK")
  1063.    set cursor off
  1064.    set talk off
  1065.    
  1066.    *-- screen colors
  1067.    clSet2 = set("ATTRIBUTES")
  1068.    clSet3 = left(clset2,at(" ",clset2)-1)
  1069.    set color to N/N,N/N,N/N
  1070.  
  1071.    *-- blank screen
  1072.    lMary=.T.
  1073.    activate screen
  1074.    @0,0 fill to 24,79 color N/N
  1075.    store 0 to nTX,nTY
  1076.  
  1077.    *-- wait for user to do something ...
  1078.    do while lMary
  1079.       do clockit  && display clock
  1080.       nTX=iif(nTX>16,0,nTX+2)
  1081.       nTY=iif(nTY>46,0,nTY+4)
  1082.    enddo
  1083.  
  1084.    *-- reset
  1085.    restore screen from sBlanker
  1086.    release screen sBlanker
  1087.    on key label alt-B do blankit        && reset on key
  1088.    do recolor with clSet2
  1089.    set cursor &cCursor.
  1090.    set talk &cTalk                      && reset talk & cursor to entry
  1091.    release aTimeAll,nTX,nTY,cSpace,cTop,cBottom,cSide,lMary,nSec8,clSet2,;
  1092.            clSet3,cCursor,cTime,nMin1,nMin2,cTalk
  1093.  
  1094. RETURN
  1095. *-- EoP: BlankIt
  1096.  
  1097. PROCEDURE ClockIt 
  1098. *-------------------------------------------------------------------------------
  1099. *-- Programmer..: Bill Garrison (BILLG) and Roger Breckenridge
  1100. *-- Date........: 10/29/1992
  1101. *-- Notes.......: Display clock for BLANKER routine.
  1102. *-- Written for.: dBASE IV, 1.5
  1103. *-- Rev. History: 10/19/1992 -- Original Release
  1104. *-- Calls.......: CLOCK                Procedure in MISC.PRG
  1105. *-- Called by...: BLANKIT              Procedure in MISC.PRG
  1106. *-- Usage.......: do clockit
  1107. *-- Example.....: do clockit
  1108. *-- Returns.....: None
  1109. *-- Parameters..: None
  1110. *-------------------------------------------------------------------------------
  1111.  
  1112.    declare aTime[11,3], aTimeAll[3]
  1113.    define window wClock from m->nTX,m->nTY to m->nTX+5,m->nTY+30 ;
  1114.            color W+/N+,,GR+/R
  1115.    activate window wClock
  1116.    do clock
  1117.    nSec8=1
  1118.    do while nSec8<11             && increase/decrease movement frequency here
  1119.       cTime=iif(val(left(time(),2))>12,;
  1120.             str(val(left(time(),2))-12,2)+substr(time(),3,6),time())
  1121.       nHour1=val(left(cTime,1))+1
  1122.       nHour2=val(substr(cTime,2,1))+1
  1123.       nMin1=val(substr(cTime,4,1))+1
  1124.       nMin2=val(substr(cTime,5,1))+1
  1125.       nSec1=val(substr(cTime,7,1))+1
  1126.       nSec2=val(substr(cTime,8,1))+1
  1127.       aTimeAll[1]=aTime[nHour1,1]+" "+aTime[nHour2,1]+aTime[11,1]+;
  1128.                aTime[nMin1,1]+" "+aTime[nMin2,1]+;    
  1129.                aTime[11,1]+aTime[nSec1,1]+" "+aTime[nSec2,1]
  1130.       aTimeAll[2]=aTime[nHour1,2]+" "+aTime[nHour2,2]+aTime[11,2]+;
  1131.                aTime[nMin1,2]+" "+aTime[nMin2,2]+aTime[11,2]+;
  1132.                aTime[nSec1,2]+" "+aTime[nSec2,2]
  1133.       aTimeAll[3]=aTime[nHour1,3]+" "+aTime[nHour2,3]+aTime[11,3]+;
  1134.                aTime[nMin1,3]+" "+aTime[nMin2,3]+aTime[11,3]+;
  1135.                aTime[nSec1,3]+" "+aTime[nSec2,3]
  1136.  
  1137.       *-- display it 
  1138.       @0,21 say  '    '+iif(val(left(time(),2))>12,'P','A')+'.M.'
  1139.       @1,1 say aTimeAll[1]
  1140.       @2,1 say aTimeAll[2]
  1141.       @3,1 say aTimeAll[3]
  1142.  
  1143.       *-- get input from user?
  1144.       nSec8=nSec8+1
  1145.       nWait=inkey(1)
  1146.       if nWait=27   && wait for <Esc> key
  1147.          lMary=.F.
  1148.          exit
  1149.       endif
  1150.    enddo
  1151.    release window wClock
  1152.  
  1153. RETURN
  1154. *-- EoP: ClockIt
  1155.  
  1156. PROCEDURE Clock
  1157. *-------------------------------------------------------------------------------
  1158. *-- Programmer..: Bill Garrison (BILLG) and Roger Breckenridge
  1159. *-- Date........: 10/29/1992
  1160. *-- Notes.......: Clock Routine (part of BLANKIT) -- defines outlines of clock
  1161. *-- Written for.: dBASE IV, 1.5
  1162. *-- Rev. History: 10/29/1992 -- Original Release
  1163. *-- Calls.......: None
  1164. *-- Called by...: CLOCKIT              Procedure in MISC.PRG
  1165. *-- Usage.......: do clock
  1166. *-- Example.....: do clock
  1167. *-- Returns.....: None
  1168. *-- Parameters..: None
  1169. *-------------------------------------------------------------------------------
  1170.  
  1171.    cSpace  = ' '
  1172.    cTop    = CHR(223)  && ▀
  1173.    cBottom = CHR(220)  && ▄
  1174.    cSide   = CHR(219)  && █
  1175.  
  1176.    aTime[1,1]=cSide+cTop+cSide
  1177.    aTime[1,2]=cSide+cSpace+cSide
  1178.    aTime[1,3]=cTop+cTop+cTop
  1179.    aTime[2,1]=cSpace+cSpace+cSide
  1180.    aTime[2,2]=cSpace+cSpace+cSide
  1181.    aTime[2,3]=cSpace+cSpace+cTop
  1182.    aTime[3,1]=cTop+cTop+cSide
  1183.    aTime[3,2]=cSide+cTop+cTop
  1184.    aTime[3,3]=cTop+cTop+cTop
  1185.    aTime[4,1]=cTop+cTop+cSide
  1186.    aTime[4,2]=cSpace+cTop+cSide
  1187.    aTime[4,3]=cTop+cTop+cTop
  1188.    aTime[5,1]=cSide+cSpace+cSide
  1189.    aTime[5,2]=cTop+cTop+cSide
  1190.    aTime[5,3]=cSpace+cSpace+cTop
  1191.    aTime[6,1]=cSide+cTop+cTop
  1192.    aTime[6,2]=cTop+cTop+cSide
  1193.    aTime[6,3]=cTop+cTop+cTop
  1194.    aTime[7,1]=cSide+cTop+cTop
  1195.    aTime[7,2]=cSide+cTop+cSide
  1196.    aTime[7,3]=cTop+cTop+cTop
  1197.    aTime[8,1]=cTop+cTop+cSide
  1198.    aTime[8,2]=cSpace+cSpace+cSide
  1199.    aTime[8,3]=cSpace+cSpace+cTop
  1200.    aTime[9,1]=cSide+cTop+cSide
  1201.    aTime[9,2]=cSide+cTop+cSide
  1202.    aTime[9,3]=cTop+cTop+cTop
  1203.    aTime[10,1]=cSide+cTop+cSide
  1204.    aTime[10,2]=cTop+cTop+cSide
  1205.    aTime[10,3]=cTop+cTop+cTop
  1206.    aTime[11,1]=cSpace+cBottom+cSpace
  1207.    aTime[11,2]=cSpace+cBottom+cSpace
  1208.    aTime[11,3]=cSpace+cSpace+cSpace
  1209.  
  1210. RETURN
  1211. *-- EoP: ClockIt
  1212.  
  1213. FUNCTION AuxMsg
  1214. *-------------------------------------------------------------------------------
  1215. *-- Programmer..: Bowen Moursund (CIS: 76566,1405)
  1216. *--               From ideas by Robert Scola & Sal Ricciardi
  1217. *--               published in PC Magazine, Volume 11, Number 21
  1218. *-- Date........: 11/21/1992
  1219. *-- Notes.......: AuxMsg will output a character string to the DOS AUX
  1220. *--               device. If a dual monitor system is in use and the
  1221. *--               DOS device driver OX.SYS is loaded, the string will
  1222. *--               print on the mono monitor. Parameter 2 determines
  1223. *--               whether the string is preceeded by a linefeed or not.
  1224. *--               *********************************************************
  1225. *--               * OX.SYS must be loaded in CONFIG.SYS file, and machine *
  1226. *--               * Booted with it ...                                    *
  1227. *--               *********************************************************
  1228. *-- Written for.: dBASE IV, 1.5
  1229. *-- Rev. History: 11/21/1992 -- Original Release
  1230. *-- Calls.......: None
  1231. *-- Called by...: Any
  1232. *-- Usage.......: AuxMsg( cMsg, lLF )
  1233. *-- Example.....: ? AuxMsg( time(), .t. )
  1234. *--               cJunk = AuxMsg( cMemVar, .f. )
  1235. *--               cJunk = AuxMsg( "Hello! )
  1236. *-- Returns.....: ""
  1237. *-- Parameters..: cMsg = string to output to AUX
  1238. *--               lLF  = .t. or .f., linefeed or not
  1239. *-------------------------------------------------------------------------------
  1240.  
  1241.     parameters cMsg, lLF
  1242.     private nAux, CRLF
  1243.     CRLF = chr(13) + chr(10)
  1244.     nAux = fopen( "aux", "w" )
  1245.     if lLF
  1246.         l = fwrite( nAux, CRLF )
  1247.     endif
  1248.     if type( "cMsg" ) = "C"
  1249.         l = fwrite( nAux, cMsg )
  1250.     endif
  1251.     l = fclose( nAux )
  1252.  
  1253. RETURN ""
  1254. *-- EoF: AuxMsg()
  1255.  
  1256. FUNCTION Gcd
  1257. *-------------------------------------------------------------------------------
  1258. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  1259. *-- Date........: 12/03/1992
  1260. *-- Notes.......: Greatest common divisor of two integers.  Given two
  1261. *--               integers, returns their largest common divisor.  Returns
  1262. *--               0 if one or both are not integers, but returns the
  1263. *--               absolute value of the gcd if one or both are negative.
  1264. *--               If one is 0, returns the other.
  1265. *--                   Usually known as "Euclid's algorithm."
  1266. *--                   The algorithm used is discussed in 4.5.2 of
  1267. *--               Volume II, "The Art of Computer Programming", 2d edition,
  1268. *--               Addison-Wesley, Reading, MA, by Donald Knuth.
  1269. *-- Written for.: dBASE IV, 1.1 and 1.5
  1270. *-- Rev. History: 12/03/1992 -- Original Release
  1271. *-- Calls.......: None
  1272. *-- Called by...: Any
  1273. *-- Usage.......: Gcd( <n1>, <n2> )
  1274. *-- Example.....: ?  Gcd( 24140, 40902 )
  1275. *-- Returns.....: numeric, the Gcd, or 0 if not both integers ( 34 in example).
  1276. *-- Parameters..: n1       = numeric, one of the integers
  1277. *--               n2       = numeric, the other
  1278. *-------------------------------------------------------------------------------
  1279.  
  1280.    parameters n1, n2
  1281.  
  1282.    private nMin, nMax, nMod
  1283.  
  1284.    nMax = iif( int( n1 ) = n1 .and. int( n2 ) = n2, 1, 0 )
  1285.  
  1286.    if nMax # 0
  1287.      nMin = min( abs( n1 ), abs( n2 ) )
  1288.      nMax = max( abs( n1 ), abs( n2 ) )
  1289.  
  1290.      do while nMin > 0
  1291.        nMod = mod( nMax, nMin )
  1292.        nMax = nMin
  1293.        nMin = nMod
  1294.      enddo
  1295.    endif
  1296.  
  1297. RETURN nMax
  1298. *-- EoF: Gcd()
  1299.  
  1300. FUNCTION RandSel
  1301. *-------------------------------------------------------------------------------
  1302. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  1303. *-- Date........: 12/03/1992
  1304. *-- Notes.......: Random selection of integers.  The function requires
  1305. *--               two numeric parameters, the number nN to select and the
  1306. *--               number of items nT to select from.  It fills the first
  1307. *--               nN rows of a one-column array with an ordered random
  1308. *--               selection of the integers from 1 to nT, which may of
  1309. *--               course be used as record numbers or indices into some
  1310. *--               other data structure to select items from it.  If
  1311. *--               passed a third, character, parameter, it will place the
  1312. *--               selected numbers in the array of that name, otherwise in
  1313. *--               the array "RandSel".  If passed a fourth parameter
  1314. *--               that evaluates to .T., it will reseed the random number
  1315. *--               generator, otherwise use the next random numbers.
  1316. *--                   If the array does not exist, it will be created.  If
  1317. *--               it does exist but with two dimensions or too few rows,
  1318. *--               it will be recreated with one dimension and enough rows.
  1319. *--               If the first parameter is larger than the second, they
  1320. *--               will be swapped.
  1321. *--                   The random-number generator should usually be reseeded,
  1322. *--               either by using the "lReseed" parameter or before calling
  1323. *--               the function, except where the function is being called
  1324. *--               repeatedly either within a very short time or for related
  1325. *--               applications in which a repetition of the sequence would
  1326. *--               defeat the randomness.
  1327. *--                   For dBASE IV versions before 1.5, revise this to take
  1328. *--               only the two numeric parameters by commenting out the first
  1329. *--               "parameters" line of code below and including the next
  1330. *--               three commented lines.  The array "RandSel" will be used,
  1331. *--               and reseeding if needed must be done before calling the
  1332. *--               function.
  1333. *--                   The algorithm used is "Algorithm S" discussed
  1334. *--               in 3.4.2 of Volume II, "The Art of Computer Programming",
  1335. *--               2d edition, Addison-Wesley, Reading, MA, by Donald Knuth.
  1336. *-- Written for.: dBASE IV, 1.1 and 1.5
  1337. *-- Rev. History: 12/03/1992 -- Original Release
  1338. *-- Calls.......: None
  1339. *-- Called by...: Any
  1340. *-- Usage.......: RandSel( "<nN>,<nT> [,<cArray>] [,<lReseed>]" )
  1341. *-- Example.....: lX = RandSel( 100, reccount(), "MyArray", .T. )
  1342. *-- Returns.....: .T. if successful, or .F. if given number < 1 as parameter.
  1343. *-- Parameters..: nN       = numeric, number of integers to select
  1344. *--               nT       = numeric, highest integer to select from
  1345. *--               cArray   = character, name of the array to hold the
  1346. *--                          selected integers.  If not furnished, array
  1347. *--                          "RandSel" will be used.
  1348. *--               lReseed  = logical, .T. to reseed the random-number
  1349. *--                          generator.  Default is .F., no reseed.
  1350. *-- Side effects: Creates as needed and fills the array.
  1351. *--               Uses some random numbers from the sequence.
  1352. *-------------------------------------------------------------------------------
  1353.  
  1354.    parameters nN, nT, cArray, lReseed
  1355.  
  1356. *-- users of versions below 1.5, comment out the line above and include
  1357. *-- the three lines below
  1358.  
  1359. *   parameters nN, nT
  1360. *   private cArray, lReseed
  1361. *   store .F. to cArray, lReseed
  1362.  
  1363.    private nChoose, nTotal, lReturn, nX, nChosen, nSeen
  1364.  
  1365.    nChoose = int( min( nN, nT ) )
  1366.    nTotal = int( max( nN, nT ) )
  1367.    lReturn = ( nChoose >= 1 )
  1368.  
  1369.    if lReturn
  1370.      if type( "cArray" ) = "L"
  1371.        cArray = "RandSel"
  1372.      endif
  1373.  
  1374.      if type( "&cArray.[ nT ]" ) = "U"
  1375.        release &cArray
  1376.        public &cArray
  1377.        declare &cArray.[ nT ]
  1378.      endif
  1379.  
  1380.      if lReseed
  1381.        nX = rand( -1 )
  1382.      endif
  1383.  
  1384.      store 0 to nChosen, nSeen
  1385.      do while nChosen < nChoose
  1386.        nX = rand() * ( nTotal - nSeen )
  1387.        if nX < nChoose - nChosen
  1388.          nChosen = nChosen + 1
  1389.          &cArray.[ nChosen ] = nSeen + 1
  1390.        endif
  1391.        nSeen = nSeen + 1
  1392.      enddo
  1393.    endif
  1394.  
  1395. RETURN lReturn
  1396. *-- EoF: RandSel()
  1397.  
  1398. FUNCTION Bell
  1399. *-------------------------------------------------------------------------------
  1400. *-- Programmer..: Angus Scott-Fleming (CIS: 75500,3223)
  1401. *-- Date........: 11/25/1992
  1402. *-- Note........: Ring my chimes
  1403. *-- Written for.: dBASE IV 1.1+
  1404. *-- Rev. History: 11/25/1992 -- Original
  1405. *-- Calls.......: None
  1406. *-- Called by...: Any
  1407. *-- Usage.......: Bell()
  1408. *-- Example.....: lDummy = Bell()
  1409. *-- Returns.....: .T.
  1410. *-- Parameters..: none
  1411. *-------------------------------------------------------------------------------
  1412.  
  1413.   set console on
  1414.   if col() = 80     && to avoid spacing past the end of the screen
  1415.     @ row(), 79 say ""
  1416.   endif
  1417.   ?? chr(7)
  1418.   set console off
  1419.  
  1420. RETURN .T.
  1421. *-- EoF: Bell()
  1422.  
  1423. *-------------------------------------------------------------------------------
  1424. *-- EoP: MISC.PRG
  1425. *-------------------------------------------------------------------------------
  1426.