home *** CD-ROM | disk | FTP | other *** search
/ Shareware Super Platinum 8 / Shareware Super Platinum 8.iso / mac / PROGTOOL / LIB211.ZIP;1 / MISC.PRG < prev    next >
Encoding:
Text File  |  1993-12-21  |  84.3 KB  |  2,264 lines
  1. *-----------------------------------------------------------------------
  2. *-- Program...: MISC.PRG
  3. *-- Programmer: Ken Mayer (CIS: 71333,1030)
  4. *-- Date......: 08/31/1993
  5. *-- Notes.....: These are the miscellaneous functions/procedures from 
  6. *--             the PROC file that aren't as commonly used as the 
  7. *--             others. See README.TXT for details on how to use this 
  8. *--             library file.
  9. *-----------------------------------------------------------------------
  10.  
  11. FUNCTION PlayIt
  12. *-----------------------------------------------------------------------
  13. *-- Programmer..: Mike Carlisle (A-T)
  14. *-- Date........: 01/21/1992
  15. *-- Notes.......: This function (from Technotes, issue??) will play a 
  16. *--               song stored in a memory variable (array).
  17. *--               This is a two dimensional array, with the first 
  18. *--               dimension defined being the # of notes, each note 
  19. *--               having two parts.
  20. *--               For a song with 12 notes, the declare statement is:
  21. *--                 DECLARE aSong[12,2]
  22. *--               aSong[1,1] is the pitch of the first note.
  23. *--               aSong[1,2] is the duration of the first note.
  24. *--               Pitches are defined from C below Middle C to B below 
  25. *--               Middle C. These are from a "tempered" scale. Values 
  26. *--               can be raised an octave by doubling the number, 
  27. *--               lowered by halving it.
  28. *--               Duration can be from 1 to 20.
  29. *--                           Note   Value
  30. *--                           C      261
  31. *--                           C#     277
  32. *--                           D      294
  33. *--                           D#     311
  34. *--                           E      329
  35. *--                           F      349
  36. *--                           F#     370
  37. *--                           G      392
  38. *--                           G#     415
  39. *--                           A      440
  40. *--                           A#     466
  41. *--                           B      494
  42. *-- Written for.: dBASE IV, 1.1
  43. *-- Rev. History: 01/21/1992 - Modified to allow use of parameter to 
  44. *--               choose the song to be played. This alleviates the 
  45. *--               need for the procedures SONG1 and SONG2 and the 
  46. *--               memfile created by them.
  47. *--               Two songs are provided (see below) ...
  48. *-- Calls.......: None
  49. *-- Called by...: Any
  50. *-- Usage.......: PlayIt(<nSong>)
  51. *-- Example.....: @5,10 say "Enter last name: " get lName valid required
  52. *--                      .not. empty(lName);
  53. *--                      error PlayIt(1)+"There must be a lastname ..."
  54. *--               Read
  55. *--                 && OR
  56. *--               ?? PlayIt(2)
  57. *-- Returns.....: Nul (or Beep on invalid parameter)
  58. *-- Parameters..: nSong = Song number. Programmer might consider adding 
  59. *--                       to the list below for any songs added for 
  60. *--                       documentation purposes ...
  61. *--                       VALID VALUES/SONGS:
  62. *--                         1  =  Dirge
  63. *--                         2  =  "Touchdown"
  64. *-----------------------------------------------------------------------
  65.  
  66.    parameter nSong
  67.    private aSong, nCounter
  68.    
  69.    *-- check for valid type of parameter ... must be numeric ...
  70.    if .not. type("nSong") $ "NF"
  71.       return chr(7)
  72.    endif
  73.    
  74.    *-- get the integer value of nSong ... in case someone tries a 
  75.    *-- "fast one"
  76.    m->nSong = int(m->nSong)
  77.    
  78.    *-- load song
  79.    do case
  80.       case m->nSong = 1  && dirge
  81.          declare aSong[12,2]          && 12 notes, 2 parts each
  82.          store 220     to aSong[1,1]  && pitch
  83.          store  10     to aSong[1,2]  && duration
  84.          store 220     to aSong[2,1]
  85.          store  10     to aSong[2,2]
  86.          store 220     to aSong[3,1]
  87.          store   2     to aSong[3,2]
  88.          store 220     to aSong[4,1]
  89.          store  10     to aSong[4,2]
  90.          store 261.63  to aSong[5,1]
  91.          store   7     to aSong[5,2]
  92.          store 246.94  to aSong[6,1]
  93.          store   2     to aSong[6,2]
  94.          store 246.94  to aSong[7,1]
  95.          store   5     to aSong[7,2]
  96.          store 220     to aSong[8,1]
  97.          store   5     to aSong[8,2]
  98.          store 220     to aSong[9,1]
  99.          store   5     to aSong[9,2]
  100.          store 205     to aSong[10,1]
  101.          store   5     to aSong[10,2]
  102.          store 220     to aSong[11,1]
  103.          store  15     to aSong[11,2]
  104.       case m->nSong = 2  && "touchdown"
  105.          declare aSong[7,2]           && 7 notes, 2 parts each
  106.          store 523.5   to aSong[1,1]  && pitch
  107.          store   2     to aSong[1,2]  && duration
  108.          store 587.33  to aSong[2,1]
  109.          store   2     to aSong[2,2]
  110.          store 659.29  to aSong[3,1]
  111.          store   2     to aSong[3,2]
  112.          store 783.99  to aSong[4,1]
  113.          store   7     to aSong[4,2]
  114.          store 659.29  to aSong[5,1]
  115.          store   2     to aSong[5,2]
  116.          store 783.99  to aSong[6,1]
  117.          store  10     to aSong[6,2]
  118.       otherwise                       && not song 1 or 2, return nothing
  119.          return chr(7)
  120.    endcase
  121.    
  122.    *-- playback
  123.    m->nCounter = 1
  124.    do while type("aSong[m->nCounter,1]") = "N"
  125.       set bell to aSong[m->nCounter,1],aSong[m->nCounter,2]
  126.       ?? chr(7) at col()
  127.       m->nCounter = m->nCounter + 1
  128.    enddo
  129.    set bell to  && return value to original
  130.  
  131. RETURN ""
  132. *-- EoF: PlayIt()
  133.  
  134. PROCEDURE PageEst
  135. *-----------------------------------------------------------------------
  136. *-- Programmer..: Rachel Holmen (RAEHOLMEN)
  137. *-- Date........: 02/04/1992
  138. *-- Notes.......: This procedure estimates the number of pages needed 
  139. *--               for an output list. 
  140. *-- Written for.: dBASE IV, 1.1
  141. *-- Rev. History: 01/15/1992 - original procedure.
  142. *--               02/04/1992 - Ken Mayer - overhaul to allow the sending 
  143. *--               of parameters for fields, rather than hard coding. 
  144. *--               Attempted to make this a "black box" procedure.
  145. *-- Calls.......: CENTER               Procedure in PROC.PRG
  146. *--               SHADOW               Procedure in PROC.PRG
  147. *-- Called by...: Any
  148. *-- Usage.......: Do PageEst with <nCount>,"<cReport>",<nRecords>
  149. *-- Example.....: Use printers
  150. *--               Do PageEst with 0,"Printer for 'Hew' $ Brand",55
  151. *-- Returns.....: None
  152. *-- Parameters..: nCount   = record count for records to be printed ...
  153. *--                          if sent as "0", system will do a RECCOUNT() 
  154. *--                          for you
  155. *--               cReport  = name of report, with any filters ... 
  156. *--                          (FOR ...)
  157. *--               nRecords = number of records per page the report will
  158. *--                          handle. If sent as "0", system will 
  159. *--                          assume 60 ...
  160. *-----------------------------------------------------------------------
  161.  
  162.    parameters nCount,cReport,nRecords
  163.    private cReport2,nPos,nPage,cPage,cChoice,cCursor
  164.    
  165.    cReport2 = upper(m->cReport)
  166.    
  167.    *-- make sure we have a number of records to work with ...
  168.    if m->nCount = 0
  169.       if at("FOR",m->cReport2) > 0   && if a filter, extract the filter
  170.          m->nPos = at("FOR",m->cReport2)  && so we can count records 
  171.                                           && that match
  172.          cFilter = substr(m->cReport,m->nPos+3,;
  173.                    len(m->cReport)-(m->nPos-1))
  174.          count to m->nCount for &cFilter.
  175.       else
  176.          m->nCount = reccount()
  177.       endif
  178.    endif
  179.    
  180.    if m->nRecords = 0
  181.       m->nRecords = 60
  182.    endif
  183.    
  184.    *-- calculate the number of pages for the report ...
  185.    store int(m->nCount/m->nRecords) to m->nPage
  186.    if mod(m->nCount,m->nRecords) > 45
  187.        store m->nPage+1 to m->nPage
  188.    else
  189.       store (m->nCount/m->nRecords) to m->nPage
  190.    endif
  191.    if m->nCount>0 .and. m->nCount < m->nRecords
  192.       store 1 to m->nPage
  193.    endif
  194.    
  195.    *-- deal with displaying info, and printing the report ...
  196.    save screen to sPrinter
  197.    activate screen            && in case there are other 
  198.                               && windows on screen ...
  199.    define window wPrinter from 8,15 to 15,65 double color;
  200.                                            rg+/gb,w/n,rg+/gb
  201.    do shadow with 8,15,15,65
  202.    activate window wPrinter
  203.    
  204.    *-- figure out how much to tell the user ...
  205.    if mod(m->nCount,m->nRecords) > 19 .and. ;
  206.       mod(m->nCount,m->nRecords) < 46
  207.       store ltrim(str(m->nPage))+" and a half pages.)" to cPage
  208.    else
  209.       store ltrim(str(m->nPage))+" pages.)" to cPage
  210.    endif
  211.    
  212.    if m->nPage = 1
  213.       store "one page.)" to cPage
  214.    endif
  215.    
  216.    *-- display info ...
  217.    do center with 1,50,"",;
  218.       "There are "+ltrim(str(m->nCount))+" records."
  219.    do center with 2,50,"","(That's approximately "+m->cPage
  220.    
  221.    *-- ask if they want to generate the report?
  222.    store space(1) to cChoice
  223.    @4,8 say "Do you want to print the list? " get m->cChoice ;
  224.         picture "!" ;
  225.         valid required m->cChoice $ "YN";
  226.         error chr(7)+"Enter 'Y' or 'N'!"
  227.    read
  228.    
  229.    *-- if yes, do it ...
  230.    if m->cChoice = "Y"
  231.       clear   && just this window ...
  232.       do center with 2,50,"","Align paper in your printer."
  233.       do center with 3,50,"","Press any key to continue ..."
  234.       x=inkey(0)
  235.       clear
  236.       do center with 2,50,"","... Printing ... do not disturb ..."
  237.       cCursor = set("CURSOR")
  238.       set cursor off
  239.       set console off
  240.       report form &cReport. to print
  241.       set console on
  242.       set cursor &cCursor.
  243.    endif
  244.    
  245.    *-- cleanup
  246.    deactivate window wPrinter
  247.    release window wPrinter
  248.    restore screen from sPrinter
  249.    release screen sPrinter
  250.  
  251. RETURN
  252. *-- EoP: PageEst
  253.  
  254. FUNCTION Permutes
  255. *-----------------------------------------------------------------------
  256. *-- Programmer..: Jay Parsons (CIS: 72662,1302)
  257. *-- Date........: 03/01/1992
  258. *-- Notes.......: Permutations of nNum items taken Nhowmany at a time
  259. *--               That is, the number of possible arrangements, as
  260. *--               the different ways a president, V.P. and sec'y may
  261. *--               be chosen from a club of 10 members
  262. *-- Written for.: dBASE IV, 1.1
  263. *-- Rev. History: 03/01/1992 -- Original Release
  264. *-- Calls.......: None
  265. *-- Called by...: Any
  266. *-- Usage.......: Permutes(<nNum>,<nHowMany>)
  267. *-- Example.....: ?Permutes(10,3)
  268. *-- Returns.....: Numeric
  269. *-- Parameters..: nNum     = number of items in the entire set
  270. *--               nHowMany = number to be used at once
  271. *-----------------------------------------------------------------------
  272.  
  273.    parameters nNum, nHowmany
  274.    private nResult, nCounter
  275.    store 1 to nResult, nCounter
  276.    do while m->nCounter <= m->nHowmany
  277.       m->nResult = m->nResult * ( m->nNum + 1 - m->nCounter )
  278.       m->nCounter = m->nCounter + 1
  279.    enddo
  280.    
  281. RETURN m->nResult
  282. *-- EoF: Permutes()
  283.  
  284. FUNCTION Combos
  285. *-----------------------------------------------------------------------
  286. *-- Programmer..: Jay Parsons (CIS: 72662,1302)
  287. *-- Date........: 03/01/1992
  288. *-- Notes.......: Combinations, similar to Permutations
  289. *--               Combinations treat "1, 3" as the same as
  290. *--               "3, 1", unlike permutations.  This gives the
  291. *--               games needed for a round robin and helps with
  292. *--               figuring odds of most state lotteries.
  293. *-- Written for.: dBASE IV, 1.1
  294. *-- Rev. History: 03/01/1992 -- Original Release
  295. *-- Calls.......: None
  296. *-- Called by...: Any
  297. *-- Usage.......: Combos(<nNum>,<nHowMany>)
  298. *-- Example.....: ?Combos(10,2)
  299. *-- Returns.....: Numeric
  300. *-- Parameters..: nNum     = number of items in the entire set
  301. *--               nHowMany = number to be used at once
  302. *-----------------------------------------------------------------------
  303.  
  304.    parameters nNum, nHowmany
  305.    private nResult, nCounter
  306.    store 1 to nResult, nCounter
  307.    do while m->nCounter <= m->nHowmany
  308.       m->nResult = m->nResult * ( m->nNum + 1 - m->nCounter ) / ;
  309.                    m->nCounter
  310.       m->nCounter = m->nCounter + 1
  311.    enddo
  312.    
  313. RETURN m->nResult
  314. *-- Combos()
  315.                                                           
  316. FUNCTION BinLoad
  317. *-----------------------------------------------------------------------
  318. *-- Programmer..: Jay Parsons (CIS: 72662,1302)
  319. *-- Date........: 03/01/1992
  320. *-- Notes.......: Function to manage .bin files
  321. *--               A call to this function results in the following 
  322. *--               actions:
  323. *--          
  324. *--               If the name of a binary module alone is given as the 
  325. *--               argument, the module is loaded if necessary, and .T. 
  326. *--               is returned. If the file cannot be found, returns .F.
  327. *--               An error occurring during the load will cause a dBASE 
  328. *--               error.
  329. *--
  330. *--               If the argument "" is given, RELEASES all loaded 
  331. *--               modules and returns .T.
  332. *--
  333. *--               If the argument contains the name of a loaded binary 
  334. *--               file and "/R", RELEASEs that file only and returns .T.
  335. *--               If the file is not listed in "gc_bins_in", returns .F.
  336. *--
  337. *--               This function uses the public variable "gc_bins_in".  
  338. *--               It keeps track of the modules loaded by changing the
  339. *--               contents of that variable.  If modules are loaded or 
  340. *--               released without the use of this function, the 
  341. *--               variable will contain an inaccurate list of the 
  342. *--               modules loaded and problems will almost surely occur 
  343. *--               if this function is used later.
  344. *--
  345. *--               If more than 16 binary modules are requested over 
  346. *--               time through this function, the one that was named 
  347. *--               least recently in a call to load it by this function 
  348. *--               is released to make room for the new one.  This 
  349. *--               will not necessarily be the module last used,
  350. *--               unless care is taken to use this function to "reload" 
  351. *--               the .bin before each call.
  352. *--
  353. *--               Suggested syntax, to call the binary routine 
  354. *--               "Smedley.bin" which takes and returns two arguments:
  355. *-- 
  356. *--               IF binload( "Smedley" )
  357. *--                 CALL Smedley WITH Arg1, Arg2
  358. *--               ELSE
  359. *--                 ? "binary file not available"
  360. *--               ENDIF
  361. *-- Written for.: dBASE IV, 1.1
  362. *-- Rev. History: 03/01/1992 -- Original Release
  363. *-- Calls.......: ATCOUNT()            Function in MISC.PRG
  364. *-- Called by...: Any
  365. *-- Usage.......: BinLoad(<cBinName>)
  366. *-- Example.....: ?BinLoad("Smedley")
  367. *-- Returns.....: Logical (.T. if successful )
  368. *-- Parameters..: cBinName = name of bin file to load ...
  369. *-----------------------------------------------------------------------
  370.  
  371.    parameters cBinname
  372.    private cBin, nPlace, nTemp, lResult
  373.    cBin = ltrim( trim( upper( m->cBinName ) ) )
  374.    if type( "gc_bins_in" ) = "U"
  375.       public gc_bins_in
  376.       m->c_Bins_In = ""
  377.    endif
  378.    m->lResult = .T.
  379.    do case
  380.       case "" = m->cBin
  381.           do while "" # m->c_Bins_In
  382.              m->nPlace = at( "*", m->c_Bins_In )
  383.              m->cBin = left( m->c_Bins_In, m->nPlace - 1 )
  384.              m->c_Bins_In = substr( m->c_Bins_In, m->nPlace + 1 )
  385.              release module &cBin.
  386.           enddo
  387.           release m->c_Bins_In
  388.       case "/R" $ m->cBinName
  389.           m->cBin = trim( left( m->cBin, at( m->cBin, "/" ) - 1 ) )
  390.           if "." $ m->cBin
  391.              m->cBin = left( m->cBin, at( ".", m->cBin ) - 1 )
  392.           endif
  393.           m->nPlace = at( m->cBin, m->c_Bins_In )
  394.           if m->nPlace = 0
  395.              m->lResult = .F.
  396.           else
  397.              m->c_Bins_In = substr( m->c_Bins_In, m->nPlace + 1 )
  398.              release module &cBin.
  399.           endif
  400.        otherwise
  401.           if "." $ m->cBin
  402.              m->cBin = left( m->cBin, at( ".", m->cBin ) - 1 )
  403.           endif
  404.           if .not. file( m->cBin )
  405.              m->lResult = .F.
  406.           else
  407.              if atcount( "*", m->c_Bins_In ) > 15
  408.                 m->nPlace = at( "*", m->c_Bins_In )
  409.                 cTemp = left( m->c_Bins_In, m->nPlace - 1 )
  410.                 release module &cTemp.
  411.                 m->c_Bins_In = substr( m->c_Bins_In, m->nPlace + 1)
  412.              endif
  413.              load &cBin
  414.              m->nPlace = at( m->cBin, m->c_Bins_In )
  415.              if nPlace > 0
  416.                 m->c_Bins_In = stuff( m->c_Bins_In, m->nPlace, ;
  417.                                len( m->cBin ) + 1, "" )
  418.              endif
  419.              m->c_Bins_In = m->c_Bins_In + m->cBin + "*"
  420.           endif
  421.    endcase
  422.  
  423. RETURN m->lResult
  424. *-- EoF: BinLoad()
  425.  
  426. FUNCTION DialUp
  427. *-----------------------------------------------------------------------
  428. *-- Programmer..: Jay Parsons (CIS: 72662,1302)
  429. *-- Date........: 06/17/1992
  430. *-- Notes.......: Dial the supplied telephone number.  Returns .F. for 
  431. *--               error. This is not a full communications routine.  
  432. *--               It is designed to be used to place voice telephone 
  433. *--               calls, with the user picking up the handset after 
  434. *--               using this function to dial.
  435. *--
  436. *--               This will work only with a modem using the standard 
  437. *--               Hayes commands, and only if the port has already 
  438. *--               been set to the desired baud rate, etc., by the DOS 
  439. *--               MODE command or otherwise.  If the port and dialing 
  440. *--               method are not constant for the application, rewrite 
  441. *--               the function to accept them as additional parameters.
  442. *--
  443. *-- Written for.: dBASE IV, 1.1, 1.5
  444. *-- Rev. History: 03/01/1992 - original function.
  445. *--               04/01/1992 - Jay Parsons - modified for Version 1.5.
  446. *--               04/03/1992 - Jay Parsons - ferror() call added.
  447. *--               06/17/1992 - Jay Parsons - 1.1 version changed to use
  448. *--                              SET PRINTER TO Device rather than .bin.
  449. *-- Calls.......: Strpbrk()            Function in MISC.PRG
  450. *-- Called by...: Any
  451. *-- Usage.......: DialUp(<cPhoneNo>)
  452. *-- Example.....: x = DialUp( "555-1212" )
  453. *-- Returns.....: Logical (connect made or not)
  454. *-- Parameters..: cPhoneNo = Phone number to dial ...
  455. *-- Side effects: When used for versions before 1.1, sets the printer to
  456. *--               a COM port and does not reset it.
  457. *-----------------------------------------------------------------------
  458.  
  459.    parameters cPhoneNo
  460.    private cNumber, cPort, cDialtype, cCallarg, xTemp, nHandle,;
  461.            cString, lResult
  462.    cPort = "Com2"          && specify Com1 or Com2 as required 
  463.    cDialtype = "Tone"      && specify Tone or Pulse ( rotary ) dialing
  464.    cNumber = m->cPhoneNo
  465.    if type( "cPhoneno" ) $ "NF"
  466.       cNumber = ltrim( str( m->cPhoneNo ) )
  467.    else
  468.       do while .t.
  469.          m->xTemp = Strpbrk( m->cNumber, " ()-" )
  470.          if m->xTemp = 0
  471.             exit
  472.          endif
  473.          m->cNumber = stuff( m->cNumber, m->xTemp, 1, "" )
  474.       enddo
  475.    endif
  476.    cString = "ATD" + upper( left( cDialtype, 1 )) + m->cNumber + chr(13)
  477.    if val( substr( version(), 9, 5 ) ) < 1.5
  478.       SET PRINTER TO &cPort.
  479.       ??? m->cString
  480.       m->lResult = .T.
  481.    else
  482.       nHandle = fopen( cPort, "w" )
  483.       if ferror() # 0
  484.          RETURN .F.
  485.       endif
  486.       m->lResult = (fwrite( m->nHandle, m->cString) = len( m->cString ))
  487.       m->xTemp = fclose( m->nHandle )
  488.    endif
  489.  
  490. RETURN m->lResult
  491. *-- EoF: Dialup()
  492.  
  493. FUNCTION CurrPort
  494. *-----------------------------------------------------------------------
  495. *-- Programmer..: David P. Brown (RHEEM)
  496. *-- Date........: 03/22/1992
  497. *-- Notes.......: This procedure gets the current SET PRINTER TO 
  498. *--               information. Will return a port or a filename if set 
  499. *--               to a file. This also requires a DBF file called 
  500. *--               CURRPRT.DBF, with an MDX tag set on the only field 
  501. *--               CURRPRT, which is a character field of 80 characters.
  502. *--
  503. *--               Structure for database: CURRPRT.DBF
  504. *--               Number of data records:       0
  505. *--               Date of last update   : 03/22/92
  506. *--               Field  Field Name  Type       Width    Dec    Index
  507. *--                   1  CURRPRT     Character     80               Y
  508. *--               ** Total **                      81
  509. *--
  510. *-- Written for.: dBASE IV, 1.1
  511. *-- Rev. History: 03/18/1992 - original function.
  512. *--               03/18/1992 -- Ken Mayer (CIS: 71333,1030) to clean it 
  513. *--               up a bit, and make it a function (not requiring the 
  514. *--               public memvar that was originally required).
  515. *--               03/21/1992 -- David P. Brown (RHEEM) found bug while
  516. *--               selecting a previous work area (stored on cDBF).  
  517. *--               Changed 'select cDBF' to 'select (cDBF)'.
  518. *--               03/22/1992 -- David P. Brown (RHEEM) final revision.
  519. *--               Added check for no available work areas.  If none is 
  520. *--               available then the program returns a null.
  521. *-- Calls.......: None
  522. *-- Called by...: Any
  523. *-- Usage.......: CurrPort()
  524. *-- Example.....: ? CurrPort()
  525. *-- Returns.....: the current port, as a character value
  526. *--               Port:   LPTx:, COMx:, PRN:
  527. *--               File:   Filename (with or without drive and path, 
  528. *--                       depends on how the user entered it in the 
  529. *--                       SET command)
  530. *--               Other:  Null (no work area available)
  531. *-- Parameters..: None
  532. *-----------------------------------------------------------------------
  533.  
  534.    private cSafety, cConsole, cDBF, cPort
  535.  
  536.    *-- Check for available work area (safety check)
  537.    if select() = 0
  538.       return ""
  539.    endif
  540.    *-- Setup
  541.    cSafety = set("SAFETY")
  542.    set safety off
  543.    *-- so user can't see what's going on
  544.    cConsole = set("CONSOLE")
  545.    set console off
  546.    
  547.    if file("CURRPRT$.OUT")  && if this file exists
  548.       erase CURRPRT$.OUT    &&   delete it, so we can write on it
  549.    endif
  550.    
  551.    cDBF = alias()           && get current work area, so we can return 
  552.    
  553.    *-- Get current printer
  554.    *-- note that we are not using 'Set Printer to file ...' due to the
  555.    *-- fact that this will change the info that the 'LIST STAT' command
  556.    *-- issues ...
  557.    set alternate to currprt$.out  && direct screen input to file
  558.    set alternate on
  559.    list status                    && returns environment information
  560.    set alternate off              && turn off 'capture'
  561.    close alternate                && close file 'currprt$.out'
  562.  
  563.    select select()                && grab next available work area ...
  564.    
  565.    use currprt order currprt excl && open database called CURRPRT
  566.    zap                            && clean out old copy of this file
  567.    
  568.    append from currprt$.out type sdf
  569.                                   && import the data for manipulation
  570.    
  571.    seek "Print"
  572.    *-- This is setup to do an indexed search, since the printer 
  573.    *-- information will not always be on the same line. If it were, 
  574.    *-- we could issue a 'GO <n>' command, which would speed up the 
  575.    *-- routine. Somewhere on line 8 to 12 (or record) is 'Print 
  576.    *-- destination: <port/file>'. The seek looks for the first word. 
  577.    *-- The command below trims out the first part of the line, and 
  578.    *-- extra spaces as well. This will return the information after
  579.    *-- the colon.
  580.    cPort = upper(trim(right(currprt->currprt,60))) 
  581.                                                  && always in upper case
  582.    
  583.    *-- clean up
  584.    use
  585.    
  586.    if len(trim(m->cDBF)) > 0
  587.       select (m->cDBF)
  588.    else
  589.       select 1
  590.    endif
  591.    
  592.    *-- erase this file
  593.    erase currprt$.out 
  594.    
  595.    *-- return safety and console to previous states ...
  596.    set safety &cSafety.
  597.    set console &cConsole.
  598.    
  599. RETURN m->cPort
  600. *-- EoF: CurrPort()
  601.  
  602. FUNCTION FileLock
  603. *-----------------------------------------------------------------------
  604. *-- Programmer..: Miriam Liskin
  605. *-- Date........: 04/27/1992
  606. *-- Notes.......: Taken from Miriam Liskin's dBASE IV, 1.1 Programming 
  607. *--               Book. This routine modified by Ken Mayer to handle 
  608. *--               slightly fancier processing ...
  609. *-- Written for.: dBASE IV, 1.1
  610. *-- Rev. History: 04/27/1992 -- Modified by Ken Mayer to give cleaner 
  611. *--               windows and such.
  612. *-- Calls.......: CENTER               Procedure in PROC.PRG
  613. *--               SHADOW               Procedure in PROC.PRG
  614. *--               COLORBRK()           Function in PROC.PRG
  615. *-- Called by...: Any
  616. *-- Usage.......: FileLock("<cColor>") 
  617. *-- Example.....: if FileLock(cl_Wind1)
  618. *--                  *-- pack/reind/whatever you need to do to database
  619. *--               else
  620. *--                  *-- do whatever processing necessary if file not
  621. *--                  *-- available for locking at this time
  622. *--               endif
  623. *-- Returns.....: Logical (.t./.f.)
  624. *-- Parameters..: cColor = Color combination for window ...
  625. *-----------------------------------------------------------------------
  626.  
  627.    parameters cColor
  628.    private nCount,lLock,x,cCurNorm,cCurBox,cTempCol
  629.    
  630.    *-- deal with dBASE IV standard errors -- we don't want program 
  631.    *-- bombing
  632.    on error ??
  633.    
  634.    *-- deal with screen stuff ...
  635.    *-- get it started ...
  636.    m->nCount = 1   && start at 1
  637.    m->lLock = .t.  && assume true
  638.    
  639.    *-- try 100 times
  640.    do while m->nCount <= 100 .and. .not. flock() .and. inkey() = 0
  641.       m->nCount = m->nCount + 1
  642.    enddo
  643.    
  644.    *-- if we can't lock the file, let the user know ...
  645.    if .not. flock()
  646.       m->lLock = .f.
  647.       save screen to sLock
  648.       *-- save colors
  649.       cCurNorm = colorof("NORMAL")
  650.       cCurBox  = colorof("BOX")
  651.       *-- set new colors
  652.       cTempCol = colorbrk(cColor,1)
  653.       set color of normal to &cTempCol.
  654.       cTempCol = colorbrk(cColor,3)
  655.       set color of box to &cTempCol.
  656.       *-- define window, display message
  657.       activate screen
  658.       define window wLock from 10,15 to 18,65 double
  659.       do shadow with 10,15,18,65
  660.       activate window sLock
  661.       do center with 1,50,"","The file cannot be locked at this time"
  662.       do center with 2,50,"","Please try again."
  663.       x = inkey(0)
  664.       *-- cleanup
  665.       deactivate window wLock
  666.       release window wLock
  667.       restore screen from sLock
  668.       release screen sLock
  669.       *-- reset colors
  670.       set color of normal to &cCurNorm.
  671.       set color of box    to &cCurBox.
  672.    endif
  673.    
  674.    *-- clean up screen, etc.
  675.    on error
  676.    
  677. RETURN m->lLock
  678. *-- EoF: FileLock()
  679.  
  680. FUNCTION RecLock
  681. *-----------------------------------------------------------------------
  682. *-- Programmer..: Miriam Liskin
  683. *-- Date........: 04/27/1992
  684. *-- Notes.......: Taken from Miriam Liskin's dBASE IV, 1.1 Programming 
  685. *--               Book. This function attempts to lock current record 
  686. *--               in active database. 
  687. *-- Written for.: dBASE IV, 1.1
  688. *-- Rev. History: 04/27/1992 -- Modified by Ken Mayer to give cleaner 
  689. *--               windows and such.
  690. *-- Calls.......: SHADOW               Procedure in PROC.PRG
  691. *--               COLORBRK()           Function in PROC.PRG
  692. *-- Called by...: Any
  693. *-- Usage.......: RecLock("<cColor>") 
  694. *-- Example.....: if RecLock("&cl_Wind1")
  695. *--                  *-- process record
  696. *--               else
  697. *--                  *-- return to menu, or whatever processing your 
  698. *--                  *-- routine does at this point
  699. *--               endif
  700. *-- Returns.....: Logical (.t./.f.)
  701. *-- Parameters..: cColor = Color combination for window ...
  702. *-----------------------------------------------------------------------
  703.  
  704.    parameters cColor
  705.    private nCount, lLock, cRetry, cCurNorm, cCurBox, cTempCol
  706.    
  707.    *-- deal with dBASE IV standard errors -- we don't want program 
  708.    *-- bombing
  709.    on error ??
  710.    
  711.    *-- deal with screen
  712.    *-- start trying -- we will give the user the option to exit -- each 
  713.    *-- time they unsuccessfully lock the record.
  714.    m->lLock = .t.   && assume true
  715.    do while .t.  && main loop
  716.       m->nCount = 1 && initialize each time we try ...
  717.       
  718.       *-- effectively a time-delay loop ...
  719.       do while m->nCount <= 100 .and. .not. rLock() .and. inkey() = 0
  720.          m->nCount = m->nCount + 1
  721.       enddo
  722.       
  723.       *-- if we CAN lock it, we're done, get outta here ...
  724.       if rlock()
  725.          m->lLock = .t.
  726.          exit
  727.       
  728.       else
  729.       
  730.          *-- otherwise, let the user know we couldn't do it, and ask if
  731.          *-- they want to try again ...
  732.          save screen to sLock
  733.          *-- save colors
  734.          cCurNorm = colorof("NORMAL")
  735.          cCurBox  = colorof("BOX")
  736.          *-- set new colors
  737.          cTempCol = colorbrk(cColor,1)
  738.          set color of normal to &cTempCol.
  739.          cTempCol = colorbrk(cColor,3)
  740.          set color of box to &cTempCol.
  741.          *-- define window ...
  742.          activate screen
  743.          define window wLock from 10,15 to 18,65 double
  744.          do shadow with 10,15,18,65
  745.          activate window wLock
  746.          m->lLock = .f.
  747.          cRetry = 'N'
  748.          @1,3 say "This record is being updated at another"
  749.          @2,3 say "workstation. You can try again now,"
  750.          @3,3 say "to access the record, or return to it"
  751.          @4,3 say "later."
  752.          @6,3 say "Do you want to try again now? " get m->cRetry;
  753.             picture "!";
  754.             valid required m->cRetry $ "YN";
  755.             error chr(7)+"Enter 'Y' or 'N'"
  756.          read
  757.          *-- cleanup
  758.          deactivate window wLock
  759.          release window wLock
  760.          restore screen from sLock
  761.          release screen sLock
  762.          *-- reset colors
  763.          set color of normal to &cCurNorm.
  764.          set color of box    to &cCurBox.
  765.          
  766.          if cRetry = "N"
  767.             exit
  768.          endif  && cRetry = "N"
  769.          
  770.       endif  && rLock()
  771.       
  772.    enddo  && end of main loop
  773.    
  774.    *-- cleanup
  775.    on error
  776.  
  777. RETURN m->lLock
  778. *-- EoF: RecLock()
  779.  
  780. FUNCTION UserId
  781. *-----------------------------------------------------------------------
  782. *-- Programmer..: Angus Scott-Fleming (ANGUSSF)
  783. *-- Date........: 04/20/1992
  784. *-- Notes.......: Returns log-in USER ID regardless of Network Type
  785. *--               *************************************************
  786. *--               ** IF DBASE IV VERSION IS < 1.5 THIS REQUIRES  **
  787. *--               ** USERID.BIN                                  **
  788. *--               *************************************************
  789. *-- Written for.: dBASE IV v1.5, will work in 1.1, if you use EMPTY()
  790. *-- Rev. History: 10/27/1992 -- Ken Mayer cleaned up a tad ...
  791. *-- Calls.......: None if version 1.5, EMPTY() if version 1.1
  792. *-- Called by...: Any
  793. *-- Usage.......: UserID()
  794. *-- Example.....: ? UserID()
  795. *-- Returns.....: Character String (up to 8 characters)
  796. *-- Parameters..: None
  797. *-----------------------------------------------------------------------
  798.  
  799.    private cTemp
  800.    if network()
  801.       if .not. isblank(getenv("USERID"))
  802.          *-- if you're working on a Lantastic net, USERID will lock the
  803.          *-- system up. Use a DOS environment variable USERID instead.
  804.          *-- This also works as a temporary override for testing access 
  805.          *-- levels.
  806.          cTemp = left(getenv("USERID"),8)
  807.       else
  808.          if val(right(version(),3)) => 1.5   && version 1.5 of dBASE IV
  809.             cTemp = id()
  810.          else
  811.             cTemp = space(48)
  812.             if file("USERID.BIN")
  813.                load userid
  814.                call userid with cTemp
  815.                release module userid
  816.             endif && file("USERID.BIN")
  817.          endif && val(right...)
  818.       endif && .not. isblank(getenv ...
  819.    else
  820.       cTemp = ""
  821.    endif  && network()
  822.  
  823. RETURN left(m->cTemp,8)  && which MIGHT be empty ...
  824. *-- EoF: UserID()
  825.  
  826. PROCEDURE DosShell
  827. *-----------------------------------------------------------------------
  828. *-- Programmer..: Bowen Moursund (CIS: 72662,436)
  829. *-- Date........: 06/10/1992
  830. *-- Notes.......: Swaps out dBASE from memory, loads a DOS shell
  831. *-- Written for.: dBASE IV v1.5
  832. *-- Rev. History: 06/10/1992 -- Original Release
  833. *-- Calls.......: TempName()           Function in FILES.PRG
  834. *-- Called by...: Any
  835. *-- Usage.......: do DosShell with <cAppName>
  836. *-- Example.....: do DosShell with "MyApp"
  837. *-- Parameters..: cAppName - the name of the application
  838. *-----------------------------------------------------------------------
  839.    parameter cAppName
  840.  
  841.    private cDir, lCursOff, cBatFile, nFH, nResult
  842.    cAppName = iif(pcount() = 0, "the application", m->cAppName)
  843.    private all
  844.    cDir = set("directory")
  845.    lCursOff = ( set("cursor") = "OFF" )
  846.    cBatFile = tempname("bat") + ".bat"
  847.    nFH = fcreate(m->cBatFile)
  848.    if m->nFH > 0
  849.       nBytes = fputs(m->nFH,"@echo off")
  850.       nBytes = fputs(m->nFH,"cls")
  851.       nBytes = fputs(m->nFH,"echo " + chr(255))  && echo a blank line
  852.       nBytes = fputs(m->nFH,"echo NOTE: Enter EXIT to resume " + ;
  853.                      m->cAppName + ".")
  854.       nBytes = fwrite(m->nFH,getenv("comspec"))
  855.       null = fclose(m->nFH)
  856.       set cursor on
  857.       m->nResult = run(.f., m->cBatFile, .t.)
  858.       if m->nResult # 0
  859.          run &cBatFile.
  860.       endif
  861.       erase (m->cBatFile)
  862.    else
  863.       cComSpec = getenv("comspec")
  864.       set cursor on
  865.       run &cComSpec.
  866.     endif
  867.     if m->lCursOff
  868.        set cursor off
  869.     endif
  870.     set directory to &cDir.
  871.  
  872. RETURN
  873. *-- EoP: DosShell
  874.  
  875. FUNCTION IsDisk
  876. *-----------------------------------------------------------------------
  877. *-- Programmer...: Ken Mayer (CIS: 71333,1030)
  878. *-- Date.........: 07/13/1992
  879. *-- Notes........: This routine is useful to check a drive for a valid 
  880. *--                disk in in it (Valid means it is in the drive, with
  881. *--                the door closed, and is formatted ...). 
  882. *--                ***********************
  883. *--                ** REQUIRES DISK.BIN **
  884. *--                ***********************
  885. *-- Written for.: dBASE IV, 1.5
  886. *-- Rev. History: 07/13/1992 -- Original Release
  887. *-- Called by...: None
  888. *-- Calls.......: CENTER               Procedure in PROC.PRG
  889. *--               SHADOW               Procedure in PROC.PRG
  890. *-- Usage.......: IsDisk(<cDrive>,<cMessCol>,<cErrCol>)
  891. *-- Example.....: IsDisk("cDrive","rg+/gb","rg+/r")
  892. *-- Returns.....: Logical
  893. *-- Parameters..: cDrive   = drive name -- single letter, no colon 
  894. *--                          (i.e., "A")
  895. *--               cMessCol = color for message box
  896. *--               cErrCol  = color for error message
  897. *-----------------------------------------------------------------------
  898.  
  899.    parameters cDrive, cMessCol, cErrCol
  900.  
  901.    private nX, cDrive2
  902.    
  903.    *-- deal with message window
  904.    save screen to sDisk
  905.    activate screen
  906.    define window wDisk from 9,15 to 12,65 double color ;
  907.                   &cMessCol.,,&cMessCol.
  908.    do shadow with 9,15,12,65
  909.    activate window wDisk
  910.    *-- display message ...
  911.    do center with 0,50,m->cMessCol,;
  912.       "Place disk in drive "+m->cDrive+": and close drive door."
  913.    do center with 1,50,cMessCol,;
  914.       "Press any key when ready ..."
  915.    set cursor off
  916.    nX=inkey(0)
  917.    set cursor on
  918.    deactivate window wDisk
  919.    restore screen from sDisk
  920.  
  921.    *-- check for a valid drive. This uses the BIN file: DISK.BIN to 
  922.    *-- do so.
  923.    load disk                 && load the BIN file
  924.    cDrive2 = m->cDrive       && save the current setting in case 
  925.                              && there's a prob.
  926.    call disk with m->cDrive2 && check to see if it's valid
  927.    activate screen
  928.    define window wDisk from 7,10 to 14,70 double ;
  929.                       color &cErrCol.,,&cErrCol.
  930.    do while m->cDrive2 = 'X'    
  931.                       && perform loop if value of cDrive2 is 'X' (error)
  932.       do shadow with 7,10,14,70
  933.       activate window wDisk
  934.       do center with 0,60,m->cErrCol,;
  935.          "** DRIVE ERROR **"
  936.       do center with 2,60,m->cErrCol,;
  937.          "Check to make sure a valid (formatted) disk is in drive,"
  938.       do center with 3,60,m->cErrCol,;
  939.          "and that the drive door is closed properly."
  940.       do center with 5,60,m->cErrCol,;
  941.          "Press <Esc> to exit, any other key to continue ..."
  942.       set cursor off
  943.       nX=inkey(0)
  944.       set cursor on
  945.       deactivate window wDisk
  946.       restore screen from sDisk
  947.       if m->nX = 27                 && user pressed <Esc>
  948.          release module disk
  949.          release window wDisk
  950.          release screen sDisk
  951.          RETURN .F.
  952.       endif
  953.       cDrive2 = m->cDrive          && reset cDrive2 from original
  954.       call disk with m->cDrive2    && check for validity again ...
  955.    enddo
  956.  
  957.    *-- cleanup
  958.    release module Disk     && remove module from RAM so we can continue
  959.    restore screen from sDisk
  960.    release screen sDisk
  961.    release window wDisk
  962.  
  963. RETURN .t.
  964. *-- EoF: IsDisk()
  965.  
  966. FUNCTION IsDisk2
  967. *-----------------------------------------------------------------------
  968. *-- Programmer...: Ken Mayer (CIS: 71333,1030)
  969. *-- Date.........: 12/15/1993
  970. *-- Notes........: This routine is useful to check a drive for a valid 
  971. *--                disk in in it (Valid means it is in the drive, with
  972. *--                the door closed, and is formatted ...). This version
  973. *--                of the above (ISDISK()) checks to see if the disk
  974. *--                is write-protected, also.
  975. *--                *************************
  976. *--                ** REQUIRES ISDISK.BIN **
  977. *--                *************************
  978. *-- Written for.: dBASE IV, 1.5
  979. *-- Rev. History: 07/13/1992 -- Original Release
  980. *-- Called by...: None
  981. *-- Calls.......: CENTER               Procedure in PROC.PRG
  982. *--               SHADOW               Procedure in PROC.PRG
  983. *-- Usage.......: IsDisk(<cDrive>,<cMessCol>,<cErrCol>)
  984. *-- Example.....: IsDisk("cDrive","rg+/gb","rg+/r")
  985. *-- Returns.....: Logical
  986. *-- Parameters..: cDrive   = drive name -- single letter, no colon 
  987. *--                          (i.e., "A")
  988. *--               cMessCol = color for message box
  989. *--               cErrCol  = color for error message
  990. *-----------------------------------------------------------------------
  991.  
  992.    parameters cDrive, cMessCol, cErrCol
  993.    private nX, cDrive2
  994.    
  995.    *-- deal with message window
  996.    save screen to sDisk
  997.    activate screen
  998.    define window wDisk from 9,15 to 12,65 double color ;
  999.                   &cMessCol.,,&cMessCol.
  1000.    do shadow with 9,15,12,65
  1001.    activate window wDisk
  1002.    *-- display message ...
  1003.    do center with 0,50,m->cMessCol,;
  1004.       "Place disk in drive "+m->cDrive+": and close drive door."
  1005.    do center with 1,50,cMessCol,;
  1006.       "Press any key when ready ..."
  1007.    set cursor off
  1008.    nX=inkey(0)
  1009.    set cursor on
  1010.    deactivate window wDisk
  1011.    restore screen from sDisk
  1012.  
  1013.    *-- check for a valid drive. This uses the BIN file: ISDISK.BIN to 
  1014.    *-- do so.
  1015.    load isdisk                 && load the BIN file
  1016.    cDrive2 = m->cDrive         && save the current setting in case 
  1017.                                && there's a prob.
  1018.    call isdisk with m->cDrive2 && check to see if it's valid
  1019.    activate screen
  1020.    define window wDisk from 7,10 to 14,70 double ;
  1021.                       color &cErrCol.,,&cErrCol.
  1022.    do while m->cDrive2 $ 'WX'  && 'W' = Write protected
  1023.                                && 'X' = other error
  1024.       do shadow with 7,10,14,70
  1025.       activate window wDisk
  1026.       do center with 0,60,m->cErrCol,;
  1027.          "** DRIVE ERROR **"
  1028.       if m->cDrive2 = "X"
  1029.          do center with 2,60,m->cErrCol,;
  1030.             "Check to make sure a valid (formatted) disk is in drive,"
  1031.          do center with 3,60,m->cErrCol,;
  1032.             "and that the drive door is closed properly."
  1033.        else
  1034.          do center with 2,60,m->cErrCol,;
  1035.             "Disk is write-protected -- remove write-protect tab."
  1036.       endif
  1037.       do center with 5,60,m->cErrCol,;
  1038.          "Press <Esc> to exit, any other key to continue ..."
  1039.       set cursor off
  1040.       nX=inkey(0)
  1041.       set cursor on
  1042.       deactivate window wDisk
  1043.       restore screen from sDisk
  1044.       if m->nX = 27                 && user pressed <Esc>
  1045.          release module isdisk
  1046.          release window wDisk
  1047.          release screen sDisk
  1048.          RETURN .F.
  1049.       endif
  1050.       cDrive2 = m->cDrive            && reset cDrive2 from original
  1051.       call isdisk with m->cDrive2    && check for validity again ...
  1052.    enddo
  1053.  
  1054.    *-- cleanup
  1055.    release module IsDisk   && remove module from RAM so we can continue
  1056.    restore screen from sDisk
  1057.    release screen sDisk
  1058.    release window wDisk
  1059.  
  1060. RETURN .t.
  1061. *-- EoF: IsDisk()
  1062.  
  1063. PROCEDURE BlankIt
  1064. *-----------------------------------------------------------------------
  1065. *-- Programmer..: Bill Garrison (BILLG), Roger Breckenridge 
  1066. *-- Date........: 08/29/1993
  1067. *-- Notes.......: Screen Saver from within dbase - uploaded to Public
  1068. *--               Domain
  1069. *-- Written for.: dBase IV 1.5  (probably work with 1.1 though)
  1070. *-- Rev. History: Original clock prg was from Michael Irwin, who I
  1071. *--               believe expanded on it from source unknown.
  1072. *--               10/29/1992: Modified original program received at
  1073. *--                           Ashton-Tate Seminar a year or so ago.
  1074. *--                           Fine tuned it and added moving-clock
  1075. *--                           feature.
  1076. *--               11/02/1992: Modified -- Ken Mayer -- dUFLP and added
  1077. *--                           Jay's RECOLOR routine, as SET COLOR TO
  1078. *--                           does not reset properly.
  1079. *--               01/08/1992: Fixed ON KEY reset, which was to "Blanker",
  1080. *--                           not "Blankit".
  1081. *--               08/29/1993 - Jay Parsons.  Tightened code, added notes
  1082. *--                           about "ON KEY" usage, changed to halt on
  1083. *--                           any keypress.
  1084. *-- Calls.......: CLOCKDEF             Procedure in MISC.PRG
  1085. *--             : RECOLOR              Procedure in PROC.PRG
  1086. *-- Called by...: Any
  1087. *-- Usage.......: Do BLANKIT
  1088. *-- Example.....: ON KEY LABEL Alt-B DO BlankIt
  1089. *-- Returns.....: None
  1090. *-- Parameters..: None
  1091. *-----------------------------------------------------------------------
  1092.    
  1093. *  The next code line, and the later on key line restoring the trap,
  1094. *  should be changed to the label of the key being used, and the
  1095. *  asterisk removed, if this is being called by an on-key trap.
  1096. *  on key label alt-B           && turn off key that called this prg
  1097.  
  1098.    save screen to sBlanker
  1099.    private cTimeAll,cChar,m->nTX,nTY,lNoKey,clSet2,cTalk,cCursor,cEsc
  1100.    
  1101.    *-- save settings
  1102.    cCursor= set("CURSOR")
  1103.    cEsc   = set("ESCAPE")
  1104.    cTalk  = set("TALK")
  1105.    set cursor off
  1106.    set talk off
  1107.    set escape off
  1108.    
  1109.    *-- screen colors
  1110.    clSet2 = set("ATTRIBUTES")
  1111.    set color to N/N,N/N,N/N
  1112.    activate screen
  1113.    clear
  1114.  
  1115.    *-- declare arrays and initialize display strings
  1116.    declare cChar[ 11 ]                && 10 digits and colon
  1117.    declare cTimeAll[ 3 ]              && the display strings
  1118.    store space( 27 ) to cTimeall[ 1 ], cTimeall[ 2 ], cTimeall[ 3 ]
  1119.  
  1120.    *-- define the big characters
  1121.    do ClockDef
  1122.  
  1123.    *-- wait for user to do something ...
  1124.    store 0 to m->nTX,m->nTY
  1125.    lNoKey = .T.
  1126.    do while m->lNoKey
  1127.       do ClockIt with 10              && display clock 10 seconds
  1128.       m->nTX = iif( m->nTX > 16, 0, m->nTX + 2 )  && move the clock
  1129.       m->nTY = iif( m->nTY > 46, 0, m->nTY + 4 )
  1130.    enddo
  1131.  
  1132.    *-- reset
  1133.    do recolor with m->clSet2
  1134.    if m->cCursor = "ON"
  1135.      set cursor on
  1136.    endif
  1137.    if m->cEsc = "ON"
  1138.      set escape on
  1139.    endif
  1140.    if m->cTalk = "ON"
  1141.      set talk on
  1142.    endif
  1143.    restore screen from sBlanker
  1144.    release screen sBlanker
  1145. *  see note above about next line
  1146. *  on key label alt-B do blankit        && reset on key
  1147.  
  1148. RETURN
  1149. *-- EoP: BlankIt
  1150.  
  1151. PROCEDURE ClockIt
  1152. *-----------------------------------------------------------------------
  1153. *-- Programmer..: Bill Garrison (BILLG) and Roger Breckenridge
  1154. *-- Date........: 08/29/1993
  1155. *-- Notes.......: Display clock for BLANKIT routine.
  1156. *-- Written for.: dBASE IV, 1.5
  1157. *-- Rev. History: 10/19/1992 -- Original Release
  1158. *--             : 08/29/1993 - Jay Parsons - made nSecs a parameter,
  1159. *--               revised algorithm slightly
  1160. *-- Called by...: BLANKIT              Procedure in MISC.PRG
  1161. *-- Usage.......: do ClockIt with <nSecs>
  1162. *-- Example.....: do clockit with 10
  1163. *-- Returns.....: None
  1164. *-- Parameters..: nSecs         Number of seconds before clock shifts
  1165. *--                             on screen
  1166. *-----------------------------------------------------------------------
  1167.  
  1168.    parameters nSecs
  1169.    private nCount, cTime, cOld, nChar, nRow, nDigit, cAPm, nHrs, nAt
  1170.    define window wClock from m->nTX,m->nTY to m->nTX+5,m->nTY+30 ;
  1171.            color W+/N+,,GR+/R
  1172.    activate window wClock
  1173.    m->nCount = 0
  1174.    cTime  = time()
  1175.    cOld   = space( 8 )
  1176.    do while m->nCount < nSecs
  1177.  
  1178.       * convert time to AM/PM
  1179.       nHrs = val( left( m->cTime, 2 ) )
  1180.       if m->nHrs > 11
  1181.          cAPm = "P.M."
  1182.          if m->nHrs > 12
  1183.             nHrs = m->nHrs - 12
  1184.          endif
  1185.          cTime = right( str( 100 + m->nHrs ), 2 ) + right( m->cTime, 6 )
  1186.       else
  1187.          cAPm = "A.M."
  1188.       endif
  1189.  
  1190.       * stuff each display row with the corresponding 3 chars of the
  1191.       * new big char for that digit if changed.
  1192.       nRow = 1
  1193.       do while m->nRow < 4
  1194.          nChar = 8
  1195.          nAt = 25
  1196.          * since time changes right to left, stuff accordingly, stopping
  1197.          * when no change appears
  1198.          do while m->nChar > 0 .and. substr( m->cOld, m->nChar, 1 ) ;
  1199.               # substr( m->cTime, m->nChar, 1 )
  1200.             * colons are 11th element of array of big chars
  1201.             * others are in place of their digit except 0 = cChar[10]
  1202.             if mod( m->nChar, 3 ) = 0
  1203.                if cOld # space( 8 )     && colons are already done
  1204.                   nChar = m->nChar - 1
  1205.                   loop
  1206.                endif
  1207.                nDigit = 11
  1208.             else
  1209.                nDigit = val( substr( m->cTime, m->nChar, 1 ) )
  1210.                nDigit = iif( m->nDigit = 0, 10, m->nDigit )
  1211.             endif
  1212.             * select the three chars in the string for the digit that
  1213.             * correspond to the row and stuff them in place in the
  1214.             * display string for that row
  1215.             cTimeall[ m->nRow ] = stuff(cTimeall[ m->nRow ], m->nAt, 3,;
  1216.                  substr( cChar[ m->nDigit ], 3 * m->nRow - 2, 3 ) )
  1217.             nChar = m->nChar - 1
  1218.             * leave spaces after digits 1, 4 and 7 to separate the
  1219.             * big digits of the hours, etc.
  1220.             nAt = m->nAt - 3 - iif( mod( m->nChar, 3 ) = 1, 1, 0 )
  1221.          enddo
  1222.          nRow = m->nRow + 1
  1223.       enddo
  1224.       *-- display it
  1225.       @ 0, 25 say m->cAPm
  1226.       @ 1,  1 say cTimeAll[1]
  1227.       @ 2,  1 say cTimeAll[2]
  1228.       @ 3,  1 say cTimeAll[3]
  1229.  
  1230.       *-- get input from user?
  1231.       cOld = m->cTime
  1232.       do while right( m->cOld, 1 ) = right( m->cTime, 1 )
  1233.          if inkey() # 0
  1234.             lNoKey = .F.
  1235.             exit
  1236.          endif
  1237.          cTime = time()
  1238.       enddo
  1239.       if .not. m->lNoKey
  1240.          exit
  1241.       endif
  1242.       m->nCount = m->nCount + 1
  1243.    enddo
  1244.    release window wClock
  1245.  
  1246. RETURN
  1247. *-- EoP: ClockIt
  1248.  
  1249. PROCEDURE ClockDef
  1250. *-----------------------------------------------------------------------
  1251. *-- Programmer..: Bill Garrison (BILLG) and Roger Breckenridge
  1252. *-- Date........: 08/29/1993
  1253. *-- Notes.......: Clock Routine (part of BLANKIT) -- defines big chars,
  1254. *--               ten digits and colon, used for clock.
  1255. *--               In addition to the space, the characters used are:
  1256. *--                   ï¬‚  chr(223), top half block
  1257. *--                   â‚¬  chr(219), full block
  1258. *--                   â€¹  chr(220), bottom half block
  1259. *-- Written for.: dBASE IV, 1.5
  1260. *-- Rev. History: 10/29/1992 -- Original Release
  1261. *--               08/29/1992 - Jay Parsons - rearranged arrays and the
  1262. *--               digits for clarity
  1263. *-- Calls.......: None
  1264. *-- Called by...: BLANKIT                       Procedure in MISC.PRG
  1265. *-- Usage.......: do clock
  1266. *-- Example.....: do clock
  1267. *-- Returns.....: None
  1268. *-- Parameters..: None
  1269. *-----------------------------------------------------------------------
  1270.  
  1271.         cChar[  1 ] ="  â‚¬";
  1272.                     +"  â‚¬";
  1273.                     +"  ï¬‚"
  1274.         cChar[  2 ] ="flfl€";
  1275.                     +"€flfl";
  1276.                     +"flflfl"
  1277.         cChar[  3 ] ="flfl€";
  1278.                     +" ï¬‚€";
  1279.                     +"flflfl"
  1280.         cChar[  4 ] ="€ â‚¬";
  1281.                     +"flfl€";
  1282.                     +"  ï¬‚"
  1283.         cChar[  5 ] ="€flfl";
  1284.                     +"flfl€";
  1285.                     +"flflfl"
  1286.         cChar[  6 ] ="€flfl";
  1287.                     +"€fl€";
  1288.                     +"flflfl"
  1289.         cChar[  7 ] ="flfl€";
  1290.                     +"  â‚¬";
  1291.                     +"  ï¬‚"
  1292.         cChar[  8 ] ="€fl€";
  1293.                     +"€fl€";
  1294.                     +"flflfl"
  1295.         cChar[  9 ] ="€fl€";
  1296.                     +"flfl€";
  1297.                     +"flflfl"
  1298.         cChar[ 10 ] ="€fl€";
  1299.                     +"€ â‚¬";
  1300.                     +"flflfl"
  1301.         cChar[ 11 ] =" â€¹ ";
  1302.                     +" â€¹ ";
  1303.                     +"   "
  1304.  
  1305. RETURN
  1306. *-- EoP: ClockDef
  1307.  
  1308. FUNCTION AuxMsg
  1309. *-----------------------------------------------------------------------
  1310. *-- Programmer..: Bowen Moursund (CIS: 72662,436)
  1311. *--               From ideas by Robert Scola & Sal Ricciardi
  1312. *--               published in PC Magazine, Volume 11, Number 21
  1313. *-- Date........: 11/21/1992
  1314. *-- Notes.......: AuxMsg will output a character string to the DOS AUX
  1315. *--               device. If a dual monitor system is in use and the
  1316. *--               DOS device driver OX.SYS is loaded, the string will
  1317. *--               print on the mono monitor. Parameter 2 determines
  1318. *--               whether the string is preceeded by a linefeed or not.
  1319. *--               ******************************************************
  1320. *--               * OX.SYS must be loaded in CONFIG.SYS file, and      *
  1321. *--               * machine booted with it ...                         *
  1322. *--               ******************************************************
  1323. *-- Written for.: dBASE IV, 1.5
  1324. *-- Rev. History: 11/21/1992 -- Original Release
  1325. *-- Calls.......: None
  1326. *-- Called by...: Any
  1327. *-- Usage.......: AuxMsg( cMsg, lLF )
  1328. *-- Example.....: ? AuxMsg( time(), .t. )
  1329. *--               cJunk = AuxMsg( cMemVar, .f. )
  1330. *--               cJunk = AuxMsg( "Hello! )
  1331. *-- Returns.....: ""
  1332. *-- Parameters..: cMsg = string to output to AUX
  1333. *--               lLF  = .t. or .f., linefeed or not
  1334. *-----------------------------------------------------------------------
  1335.  
  1336.     parameters cMsg, lLF
  1337.     private nAux, CRLF
  1338.     CRLF = chr(13) + chr(10)
  1339.     nAux = fopen( "aux", "w" )
  1340.     if m->lLF
  1341.         l = fwrite( m->nAux, m->CRLF )
  1342.     endif
  1343.     if type( "cMsg" ) = "C"
  1344.         l = fwrite( m->nAux, m->cMsg )
  1345.     endif
  1346.     l = fclose( m->nAux )
  1347.  
  1348. RETURN ""
  1349. *-- EoF: AuxMsg()
  1350.  
  1351. FUNCTION Gcd
  1352. *-----------------------------------------------------------------------
  1353. *-- Programmer..: Jay Parsons (CIS: 72662,1302)
  1354. *-- Date........: 12/03/1992
  1355. *-- Notes.......: Greatest common divisor of two integers.  Given two
  1356. *--               integers, returns their largest common divisor.  
  1357. *--               Returns 0 if one or both are not integers, but returns
  1358. *--               the absolute value of the gcd if one or both are 
  1359. *--               negative.
  1360. *--               If one is 0, returns the other.
  1361. *--                   Usually known as "Euclid's algorithm."
  1362. *--                   The algorithm used is discussed in 4.5.2 of
  1363. *--               Volume II, "The Art of Computer Programming", 2d 
  1364. *--               edition, Addison-Wesley, Reading, MA, by Donald Knuth.
  1365. *-- Written for.: dBASE IV, 1.1 and 1.5
  1366. *-- Rev. History: 12/03/1992 -- Original Release
  1367. *-- Calls.......: None
  1368. *-- Called by...: Any
  1369. *-- Usage.......: Gcd( <n1>, <n2> )
  1370. *-- Example.....: ?  Gcd( 24140, 40902 )
  1371. *-- Returns.....: numeric, the Gcd, or 0 if not both integers ( 34 in 
  1372. *--                example).
  1373. *-- Parameters..: n1       = numeric, one of the integers
  1374. *--               n2       = numeric, the other
  1375. *-----------------------------------------------------------------------
  1376.  
  1377.    parameters n1, n2
  1378.  
  1379.    private nMin, nMax, nMod
  1380.  
  1381.    nMax = iif( int( m->n1 ) = m->n1 .and. int( m->n2 ) = m->n2, 1, 0 )
  1382.  
  1383.    if m->nMax # 0
  1384.       m->nMin = min( abs( m->n1 ), abs( m->n2 ) )
  1385.       m->nMax = max( abs( m->n1 ), abs( m->n2 ) )
  1386.  
  1387.       do while m->nMin > 0
  1388.          m->nMod = mod( m->nMax, m->nMin )
  1389.          m->nMax = m->nMin
  1390.          m->nMin = m->nMod
  1391.       enddo
  1392.    endif
  1393.  
  1394. RETURN m->nMax
  1395. *-- EoF: Gcd()
  1396.  
  1397. FUNCTION RandSel
  1398. *-----------------------------------------------------------------------
  1399. *-- Programmer..: Jay Parsons (CIS: 72662,1302)
  1400. *-- Date........: 12/03/1992
  1401. *-- Notes.......: Random selection of integers.  The function requires
  1402. *--               two numeric parameters, the number nN to select and 
  1403. *--               the number of items nT to select from.  It fills the 
  1404. *--               first nN rows of a one-column array with an ordered 
  1405. *--               random selection of the integers from 1 to nT, which 
  1406. *--               may of course be used as record numbers or indices 
  1407. *--               into some other data structure to select items from 
  1408. *--               it.  If passed a third, character, parameter, it will
  1409. *--               place the selected numbers in the array of that name,
  1410. *--               otherwise in the array "RandSel".  If passed a fourth
  1411. *--               parameter that evaluates to .T., it will reseed the 
  1412. *--               random number generator, otherwise use the next random
  1413. *--               numbers.
  1414. *--                   If the array does not exist, it will be created.  
  1415. *--               If it does exist but with two dimensions or too few 
  1416. *--               rows, it will be recreated with one dimension and 
  1417. *--               enough rows. If the first parameter is larger than 
  1418. *--               the second, they will be swapped.
  1419. *--                   The random-number generator should usually be 
  1420. *--               reseeded, either by using the "lReseed" parameter or 
  1421. *--               before calling the function, except where the function
  1422. *--               is being called repeatedly either within a very short 
  1423. *--               time or for related applications in which a repetition
  1424. *--               of the sequence would defeat the randomness.
  1425. *--                   For dBASE IV versions before 1.5, revise this to 
  1426. *--               take only the two numeric parameters by commenting out
  1427. *--               the first "parameters" line of code below and 
  1428. *--               including the next three commented lines.  The array
  1429. *--               "RandSel" will be used, and reseeding if needed must 
  1430. *--               be done before calling the function.
  1431. *--                   The algorithm used is "Algorithm S" discussed
  1432. *--               in 3.4.2 of Volume II, "The Art of Computer 
  1433. *--               Programming", 2d edition, Addison-Wesley, Reading, 
  1434. *--               MA, by Donald Knuth.
  1435. *-- Written for.: dBASE IV, 1.1 and 1.5
  1436. *-- Rev. History: 12/03/1992 -- Original Release
  1437. *-- Calls.......: None
  1438. *-- Called by...: Any
  1439. *-- Usage.......: RandSel( "<nN>,<nT> [,<cArray>] [,<lReseed>]" )
  1440. *-- Example.....: lX = RandSel( 100, reccount(), "MyArray", .T. )
  1441. *-- Returns.....: .T. if successful, or .F. if given number < 1 as 
  1442. *--               parameter.
  1443. *-- Parameters..: nN       = numeric, number of integers to select
  1444. *--               nT       = numeric, highest integer to select from
  1445. *--               cArray   = character, name of the array to hold the
  1446. *--                          selected integers.  If not furnished, array
  1447. *--                          "RandSel" will be used.
  1448. *--               lReseed  = logical, .T. to reseed the random-number
  1449. *--                          generator.  Default is .F., no reseed.
  1450. *-- Side effects: Creates as needed and fills the array.
  1451. *--               Uses some random numbers from the sequence.
  1452. *-----------------------------------------------------------------------
  1453.  
  1454.    parameters nN, nT, cArray, lReseed
  1455.  
  1456.    *-- users of versions below 1.5, comment out the line above and 
  1457.    *-- include the three lines below
  1458.  
  1459.    *   parameters nN, nT
  1460.    *   private cArray, lReseed
  1461.    *   store .F. to cArray, lReseed
  1462.    private nChoose, nTotal, lReturn, nX, nChosen, nSeen
  1463.  
  1464.    nChoose = int( min( m->nN, m->nT ) )
  1465.    nTotal = int( max( m->nN, m->nT ) )
  1466.    lReturn = ( m->nChoose >= 1 )
  1467.  
  1468.    if lReturn
  1469.       if type( "cArray" ) = "L"
  1470.          cArray = "RandSel"
  1471.       endif
  1472.  
  1473.       if type( "&cArray.[ m->nT ]" ) = "U"
  1474.          release &cArray.
  1475.          public &cArray.
  1476.          declare &cArray.[ m->nT ]
  1477.       endif
  1478.  
  1479.       if m->lReseed
  1480.          nX = rand( -1 )
  1481.       endif
  1482.  
  1483.       store 0 to m->nChosen, m->nSeen
  1484.       do while m->nChosen < m->nChoose
  1485.          m->nX = rand() * ( m->nTotal - m->nSeen )
  1486.          if m->nX < m->nChoose - m->nChosen
  1487.             m->nChosen = m->nChosen + 1
  1488.             store m->nSeen+1 to &cArray.[ m->nChosen ]
  1489.          endif
  1490.          m->nSeen = m->nSeen + 1
  1491.       enddo
  1492.    endif
  1493.  
  1494. RETURN m->lReturn
  1495. *-- EoF: RandSel()
  1496.  
  1497. FUNCTION Bell
  1498. *-----------------------------------------------------------------------
  1499. *-- Programmer..: Angus Scott-Fleming (CIS: 75500,3223)
  1500. *-- Date........: 11/25/1992
  1501. *-- Note........: Ring my chimes
  1502. *-- Written for.: dBASE IV 1.1+
  1503. *-- Rev. History: 11/25/1992 -- Original
  1504. *-- Calls.......: None
  1505. *-- Called by...: Any
  1506. *-- Usage.......: Bell()
  1507. *-- Example.....: lDummy = Bell()
  1508. *-- Returns.....: .T.
  1509. *-- Parameters..: none
  1510. *-----------------------------------------------------------------------
  1511.  
  1512.   set console on
  1513.   if col() = 80     && to avoid spacing past the end of the screen
  1514.      @ row(), 79 say ""
  1515.   endif
  1516.   ?? chr(7)
  1517.   set console off
  1518.  
  1519. RETURN .T.
  1520. *-- EoF: Bell()
  1521.  
  1522. FUNCTION Alarm
  1523. *-----------------------------------------------------------------------
  1524. *-- Programmer..: Angus Scott-Fleming (CIS: 75500,3223)
  1525. *-- Date........: 10/05/1993
  1526. *-- Note........: Ring my chimes in a warbling pattern
  1527. *-- Written for.: dBASE IV 1.5+
  1528. *-- Rev. History: 10/05/1993 -- Original
  1529. *--               11/02/1993 -- (Ken Mayer) added nDur parameter
  1530. *--                         so we could lengthen or shorten
  1531. *--                         duration of each part of "warble"
  1532. *-- Calls.......: None
  1533. *-- Called by...: Any
  1534. *-- Usage.......: Alarm([<nRings>][,nDur])
  1535. *-- Example.....: lDummy = Alarm(3)   or
  1536. *--               lDummy = Alarm(3,5)
  1537. *-- Returns.....: .T.
  1538. *-- Parameters..: nRings = how many times to warble? (optional --
  1539. *--                        default is 10)
  1540. *--               nDur   = duration (1-20) -- Optional, but if used
  1541. *--                        you must have a value for nRings --
  1542. *--                        using '0' will give default of 10. Duration
  1543. *--                        defaults to 10.
  1544. *-----------------------------------------------------------------------
  1545.  
  1546.    parameters nRings, nDur
  1547.    private lSaveBell, lConsole, nTimesRung, nLastKey
  1548.  
  1549.    * default is 10 rings
  1550.    if pcount() < 1
  1551.       m->nRings = 10
  1552.    endif
  1553.    *-- if we have a value for first parameter
  1554.    if pCount() => 1
  1555.       if m->nRings = 0   && if it's zero, set default to 10
  1556.          m->nRings = 10 
  1557.       endif
  1558.    endif
  1559.    *-- nDur has been passed
  1560.    if pCount() = 2
  1561.       if m->nDur < 0 .or. m->nDur > 20  && if invalid (1-20!)
  1562.          m->nDur = 10
  1563.       endif
  1564.    else
  1565.       m->nDur = 10  && if nothing passed at all ...
  1566.    endif
  1567.  
  1568.    *-- init a couple fields
  1569.    store 0 to m->nTimesRung, m->nLastKey
  1570.    m->lConsole = (set("console") = "ON")
  1571.    set console on
  1572.    m->lSaveBell = (set("BELL") = "ON")
  1573.    set bell on
  1574.    if col() = 80     && to avoid spacing past the end of the screen
  1575.       @ row(), 79 say ""
  1576.    endif
  1577.  
  1578.    * Ring the bells.  Exit if user is paying attention and presses a key
  1579.    do while m->nTimesRung < m->nRings .and. m->nLastKey = 0
  1580.       set bell to 400,nDur
  1581.       ?? chr(7)
  1582.       set bell to 1200,nDur
  1583.       ?? chr(7)
  1584.       m->nLastKey = inkey()
  1585.       m->nTimesRung = m->nTimesRung + 1
  1586.    enddo
  1587.  
  1588.    * reset the bell, both ON/OFF and tone/duration
  1589.    if m->lSaveBell
  1590.       set bell on
  1591.    endif
  1592.    set bell to
  1593.  
  1594.    * reset the console
  1595.    if .not. m->lConsole
  1596.       set console off
  1597.    endif
  1598.  
  1599. RETURN .T.
  1600. *-- EoF: Alarm()
  1601.  
  1602. FUNCTION GetPorts
  1603. *----------------------------------------------------------------------
  1604. *-- Programmer..: Angus Scott-Fleming, GeoApplications [75500,3223]
  1605. *-- Date........: 10/26/1993
  1606. *-- Notes.......: Get list of available printer ports
  1607. *-- Written for.: dBASE IV, 1.5
  1608. *-- Rev. History: 10/26/1993 -- Original
  1609. *-- Calls.......: PortCheck, Warning (use your own)
  1610. *-- Called by...: Any
  1611. *-- Usage.......: ? GetPorts()
  1612. *-- Example.....: PrinterList = GetPorts()
  1613. *-- Returns.....: space-separated list of available ports
  1614. *--             : list looks like "LPT1  LPT2  LPT3"
  1615. *-- Parameters..: None
  1616. *----------------------------------------------------------------------
  1617.  
  1618.    private lDummy, cOldDevice, lPrintOK, cPrinters
  1619.    cOldDevice = set("device")
  1620.    set device to screen
  1621.    store "" to cPrinters
  1622.    do PortCheck with m->cPrinters, "LPT1"
  1623.    do PortCheck with m->cPrinters, "LPT2"
  1624.    do PortCheck with m->cPrinters, "LPT3"
  1625.    do case
  1626.       case trim(m->cOldDevice) = "PRINT"
  1627.          set device to PRINT
  1628.       case trim(m->cOldDevice) = "SCREEN"
  1629.          set device to SCREEN
  1630.       case left(m->cOldDevice,4) = "FILE"
  1631.          store substr(m->cOldDevice,5) to cOldDevice
  1632.          set device to FILE (m->cOldDevice)
  1633.       otherwise
  1634.       lDummy = warning("UNKNOWN DEVICE IN GetPorts: "+m->cOldDevice)
  1635.    endcase
  1636.  
  1637. RETURN ltrim(rtrim(m->cPrinters))
  1638. *-- EoF: GetPorts()
  1639.  
  1640. PROCEDURE PortCheck
  1641. *----------------------------------------------------------------------
  1642. *-- Programmer..: Angus Scott-Fleming, GeoApplications [75500,3223]
  1643. *-- Date........: 10/26/1993
  1644. *-- Notes.......: Part of GetPorts
  1645. *-- Written for.: dBASE IV, 1.5
  1646. *-- Rev. History: 10/26/1993  original
  1647. *-- Calls.......: E_Check, GetInfo
  1648. *-- Called by...: GetPorts()
  1649. *-- Usage.......: do PortCheck with <portlist>, <port>
  1650. *-- Example.....: do PortCheck with m->cPrinters, "LPT3"
  1651. *-- Returns.....: adds <port> to <portlist> if port is available
  1652. *-- Parameters..: cPrinters =  character - list of available ports
  1653. *--               cPort     =  character - port to test for 
  1654. *--                                        availability
  1655. *----------------------------------------------------------------------
  1656.  
  1657.    parameters cPrinters, cPort
  1658.    private lPrintOK, cCurrPort, lPrintON
  1659.    lPrintOK = .T.
  1660.    on error do e_check with error(), cPrinters, cPort, lineno(), ;
  1661.             lPrintOK
  1662.    set printer to &cPort.
  1663.    store GetInfo("PRINT") to cCurrPort
  1664.    if m->cCurrPort = m->cPort .and. m->cPort = m->cCurrPort
  1665.       if .not. m->cPort $ m->cPrinters
  1666.          set device to print
  1667.          if .not. m->cPort $ m->cPrinters
  1668.             lPrintON = set("print")="ON"
  1669.             set print on
  1670.             if .not. lPrintON
  1671.                set print off
  1672.             endif
  1673.          endif
  1674.       endif
  1675.    endif
  1676.    if m->lPrintOK
  1677.       store m->cPrinters + m->cPort + "  " to cPrinters
  1678.    endif
  1679.    on error
  1680.  
  1681. RETURN
  1682. *-- EoP: PortCheck
  1683.  
  1684. PROCEDURE E_Check
  1685. *----------------------------------------------------------------------
  1686. *-- Programmer..: Angus Scott-Fleming, GeoApplications [75500,3223]
  1687. *-- Date........: 10/26/1993
  1688. *-- Notes.......: Part of GetPorts
  1689. *-- Written for.: dBASE IV, 1.5
  1690. *-- Rev. History: 10/26/1993  original
  1691. *-- Calls.......: LStr, Warning (insert your own Warning function here)
  1692. *-- Called by...: PortCheck
  1693. *-- Usage.......: on error do e_check with error(), <portlist>, ;
  1694. *--                                        <port>, lineno(), <logical>
  1695. *-- Example.....: on error do e_check with error(), cPrinters, ;
  1696. *--                                        cPort, lineno(), lPrintOK
  1697. *-- Returns.....: checks error condition after SET PRINTER TO <Port>
  1698. *--               adds <port> to <portlist> if port is available
  1699. *-- Parameters..: error_no  = numeric   - error that called E_Check
  1700. *--               cPrinters = character - list of available ports
  1701. *--               cPort     = character -  port to test for 
  1702. *--                                        availability
  1703. *--               nLineNo   = numeric   -  line number of calling 
  1704. *--                                        program
  1705. *--               lPrintOK  = logical   -  flag to set; used by 
  1706. *--                                        PortCheck
  1707. *----------------------------------------------------------------------
  1708.  
  1709.    parameters error_no, cPrinters, cPort, nLineNo, lPrintOK
  1710.    private lDummy, cOldDevice, cErrorMsg
  1711.    cErrorMsg = message()
  1712.    * Mon  10-25-1993  store old device information
  1713.    cOldDevice = set("device")
  1714.    set device to screen
  1715.    lPrintOK = .F.
  1716.    do case
  1717.       case error_no = 123  && Invalid printer port
  1718.       case error_no = 124  && Invalid printer redirection
  1719.       case error_no = 125  && Printer not ready - but the port is there!
  1720.          store m->cPrinters + m->cPort + "  " to cPrinters
  1721.       case error_no = 126  && Printer is either not connected or 
  1722.                            && turned off
  1723.          store m->cPrinters + m->cPort + "  " to cPrinters
  1724.       otherwise
  1725.          lDummy = Warning("Error # "+str(error_no,3,0)+" w/ driver " +;
  1726.                       _pdriver + " from " + prg_name,m->cErrorMsg,;
  1727.                       "Line: "+lstr(nLineNo))
  1728.    endcase
  1729.  
  1730.    do case
  1731.       case trim(m->cOldDevice) = "PRINT"
  1732.            set device to PRINT
  1733.       case trim(m->cOldDevice) = "SCREEN"
  1734.            set device to SCREEN
  1735.       case trim(m->cOldDevice) = "FILE"
  1736.            store substr(m->cOldDevice,5) to cOldDevice
  1737.            set device to FILE (m->cOldDevice)
  1738.       otherwise
  1739.            lDummy = warning("UNKNOWN DEVICE IN GetPorts/E_Check: "+;
  1740.                           m->cOldDevice)
  1741.    endcase
  1742.  
  1743. RETURN
  1744. *-- EoP: E_Check
  1745.  
  1746. FUNCTION Warning
  1747. *----------------------------------------------------------------------
  1748. *-- Programmer..: Angus Scott-Fleming, GeoApplications [75500,3223]
  1749. *-- Date........: 10/26/1993
  1750. *-- Notes.......: quick-and-dirty warning message for testing
  1751. *-- Written for.: dBASE IV, 1.5
  1752. *-- Rev. History: 10/26/1993 -- Original
  1753. *-- Calls.......: None
  1754. *-- Called by...: Any
  1755. *-- Usage.......: ? Warning(<c1>[,<c2>,<c3>,<c4>,<c5>])
  1756. *-- Example.....: ? Warning("You dummy!")
  1757. *-- Returns.....: .F.
  1758. *-- Parameters..: up to five character strings to display at EoScreen
  1759. *----------------------------------------------------------------------
  1760.  
  1761.    parameters cM1, cM2, cM3, cM4, cM5
  1762.    private cDevice, lConsole, lPrintON
  1763.    lConsole = set("console") = "ON"
  1764.    lPrintON = set("printer") = "ON"
  1765.    cDevice  = set("device")
  1766.    set print off
  1767.    set device to screen
  1768.    set console on
  1769.    do case
  1770.       case pcount() = 1
  1771.            @ 23,0 clear to 24,79
  1772.            @ 23,0 say left(m->cM1,79)
  1773.       case pcount() = 2
  1774.            @ 22,0 clear to 24,79
  1775.            @ 22,0 say left(m->cM1,79)
  1776.            @ 23,0 say left(m->cM2,79)
  1777.       case pcount() = 3
  1778.            @ 21,0 clear to 24,79
  1779.            @ 21,0 say left(m->cM1,79)
  1780.            @ 22,0 say left(m->cM2,79)
  1781.            @ 23,0 say left(m->cM3,79)
  1782.       case pcount() = 4
  1783.           @ 20,0 clear to 24,79
  1784.           @ 20,0 say left(m->cM1,79)
  1785.           @ 21,0 say left(m->cM2,79)
  1786.           @ 22,0 say left(m->cM3,79)
  1787.           @ 23,0 say left(m->cM4,79)
  1788.       otherwise
  1789.           * use the first five
  1790.           @ 19,0 clear to 24,79
  1791.           @ 19,0 say left(m->cM1,79)
  1792.           @ 20,0 say left(m->cM2,79)
  1793.           @ 21,0 say left(m->cM3,79)
  1794.           @ 22,0 say left(m->cM4,79)
  1795.           @ 23,0 say left(m->cM5,79)
  1796.    endcase
  1797.    @ 24,0 say "Press any key to continue ... " + chr(7)
  1798.    lDummy = inkey(0)
  1799.    do case
  1800.       case trim(m->cDevice) = "PRINT"
  1801.            set device to PRINT
  1802.       case trim(m->cDevice) = "SCREEN"
  1803.            set device to SCREEN
  1804.       case left(m->cDevice,4) = "FILE"
  1805.            store substr(m->cDevice,5) to cDevice
  1806.            set device to FILE (m->cDevice)
  1807.       otherwise
  1808.            @ 24,0 clear to 24,79
  1809.            @ 24,0 say chr(7) + "UNKNOWN DEVICE IN Warning: "+;
  1810.                                m->cDevice+"  press any key"
  1811.            lDummy = inkey(0)
  1812.    endcase
  1813.    if .not. m->lConsole
  1814.       set console off
  1815.    endif
  1816.    if m->lPrintON
  1817.       set printer on
  1818.    endif
  1819.  
  1820. RETURN .F.
  1821. *-- EoF: Warning()
  1822.  
  1823. *-----------------------------------------------------------------------
  1824. *-- The following are here as a courtesy ...
  1825. *-----------------------------------------------------------------------
  1826.  
  1827. FUNCTION AtCount
  1828. *-----------------------------------------------------------------------
  1829. *-- Programmer..: Jay Parsons (CIS: 72662,1302)
  1830. *-- Date........: 03/01/1992
  1831. *-- Notes.......: returns the number of times FindString is found in 
  1832. *--               Bigstring
  1833. *-- Written for.: dBASE IV
  1834. *-- Rev. History: 03/01/1992 -- Original Release
  1835. *-- Calls.......: None
  1836. *-- Called by...: Any
  1837. *-- Usage.......: AtCount("<cFindStr>","<cBigStr>")
  1838. *-- Example.....: ? AtCount("Test",;
  1839. *--                         "This is a Test string, with Test data")
  1840. *-- Returns.....: Numeric value
  1841. *-- Parameters..: cFindStr = string to find in cBigStr
  1842. *--               cBigStr  = string to look in
  1843. *-----------------------------------------------------------------------
  1844.  
  1845.    parameters cFindstr, cBigstr
  1846.    private cTarget, nCount
  1847.    
  1848.    cTarget = m->cBigstr
  1849.    m->nCount = 0
  1850.    
  1851.    do while .t.
  1852.       if at( m->cFindStr,m->cTarget ) > 0
  1853.          m->nCount = m->nCount + 1
  1854.          m->cTarget = substr( m->cTarget, at( m->cFindStr, ;
  1855.                               m->cTarget ) + 1 )
  1856.       else
  1857.          exit
  1858.       endif
  1859.    enddo
  1860.    
  1861. RETURN m->nCount
  1862. *-- EoF: AtCount()
  1863.     
  1864. FUNCTION Dec2Hex
  1865. *-----------------------------------------------------------------------
  1866. *-- Programmer..: Jay Parsons (CIS: 72662,1302)
  1867. *-- Date........: 03/01/1992
  1868. *-- Notes.......: Converts an integral number ( in decimal notation)
  1869. *--               to a hexadecimal string
  1870. *-- Written for.: dBASE IV, 1.1
  1871. *-- Rev. History: 03/01/1992 -- Original Release
  1872. *-- Calls.......: None
  1873. *-- Called by...: Any
  1874. *-- Usage.......: Dec2Hex(<nDecimal>)
  1875. *-- Example.....: ? Dec2Hex( 118 )
  1876. *-- Returns.....: Character = Hexadecimal equivalent ( "F6" in example )
  1877. *-- Parameters..: nDecimal = number to convert
  1878. *-----------------------------------------------------------------------
  1879.    
  1880.    parameters nDecimal
  1881.    private nD, cH
  1882.    nD = int( nDecimal )
  1883.    cH= ""
  1884.    do while m->nD > 0
  1885.       m->cH = substr( "0123456789ABCDEF", mod( m->nD, 16 ) + 1 , 1 );
  1886.              + m->cH
  1887.       m->nD = int( m->nD / 16 )
  1888.    enddo
  1889.    
  1890. RETURN iif( "" = m->cH, "0", m->cH )
  1891. *-- Eof: Dec2Hex()
  1892.  
  1893. FUNCTION StrPBrk
  1894. *-----------------------------------------------------------------------
  1895. *-- Programmer..: Jay Parsons (CIS: 72662,1302)
  1896. *-- Date........: 03/01/1992
  1897. *-- Notes.......: Search string for first occurrence of any of the
  1898. *--               characters in charset.  Returns its position as
  1899. *--               with at().  Contrary to ANSI.C definition, returns
  1900. *--               0 if none of characters is found.
  1901. *-- Written for.: dBASE IV
  1902. *-- Rev. History: 03/01/1992 -- Original Release
  1903. *-- Calls.......: None
  1904. *-- Called by...: Any
  1905. *-- Usage.......: StrPBrk("<cCharSet>","<cBigStr>")
  1906. *-- Example.....: ? StrPBrk("Tt",;
  1907. *--                         "This is a Test string, with Test data")
  1908. *-- Returns.....: Numeric value
  1909. *-- Parameters..: cCharSet = characters to look for in cBigStr
  1910. *--               cBigStr  = string to look in
  1911. *-----------------------------------------------------------------------
  1912.  
  1913.    parameters cCharset, cBigstring
  1914.    private nPos, nLooklen
  1915.    m->nPos = 0
  1916.    nLooklen = len( m->cBigString )
  1917.    do while m->nPos < m->nLooklen
  1918.       m->nPos = m->nPos + 1
  1919.       if at( substr( m->cBigString, m->nPos, 1 ), m->cCharset ) > 0
  1920.          exit
  1921.       endif
  1922.    enddo
  1923.    
  1924. RETURN iif(m->nPos=m->nLookLen,0,m->nPos)
  1925. *-- EoF: StrPBrk()
  1926.  
  1927. FUNCTION IsSet
  1928. *-----------------------------------------------------------------------
  1929. *-- Programmer..: Frank A. Deviney, Jr. (CIS: 72357,345)
  1930. *-- Date........: 12/18/1993
  1931. *-- Notes.......: Checks if a bit (within a byte) is "set" to 1.
  1932. *-- Written for.: dBASE IV, v2.0
  1933. *-- Rev. History: 12/18/1993 -- Original Release
  1934. *-- Calls.......: None
  1935. *-- Called by...: Any
  1936. *-- Usage.......: IsSet( <expC>, <expN> )
  1937. *-- Example.....: ? IsSet( chr(202), 4 )
  1938. *-- Returns.....: logical
  1939. *-- Parameters..: cFlags = a single ascii character, but if a string is
  1940. *--                        passed, the first character in the string will
  1941. *--                        be used.
  1942. *--               nWhich = which bit to check. LSB = 0, MSB = 7
  1943. *-----------------------------------------------------------------------
  1944.    parameters cFlags, nWhich
  1945.    private n, nCurr, nMid
  1946.  
  1947.    m->n     = asc(cFlags)
  1948.    m->nCurr = 7
  1949.    m->nMid  = 128
  1950.    do while .not. (nWhich = m->nCurr)
  1951.       if (m->n >= m->nMid)
  1952.           m->n = m->n - m->nMid
  1953.       endif
  1954.       m->nCurr = m->nCurr - 1
  1955.       m->nMid  = m->nMid / 2
  1956.    enddo
  1957.  
  1958. RETURN (m->n >= m->nMid)
  1959. *-- EoF: IsSet()
  1960.  
  1961. *----------------------------------------------------------------------
  1962. *-- The following are here to work with the GETPORTS() function
  1963. *-- above. Copies will be found in other parts of the library.
  1964. *----------------------------------------------------------------------
  1965.  
  1966. FUNCTION GetInfo
  1967. *----------------------------------------------------------------------
  1968. *-- Programmer..: Adam L. Menkes (Borland Technical Support)
  1969. *-- Date........: 10/26/1993 
  1970. *-- Notes.......: Retrieves information from STATUS that you cannot get
  1971. *--               with the dBASE IV function SET(). See 'parameters'
  1972. *--               below for list of keywords.
  1973. *--               CAUTION: If you have ALTERNATE set, you need to reset
  1974. *--               it after the function executes. SET ALTERNATE TO must
  1975. *--               be used instead of LIST STATUS TO filename, since the
  1976. *--               print destination would always show as a file. All
  1977. *--               results that are returned are returned as character
  1978. *--               types, including ones that return numbers (use VAL()
  1979. *--               to look at/use returned value as a number).
  1980. *-- Written for.: dBASE IV, 1.5
  1981. *-- Rev. History: 04/01/1992 -- Original
  1982. *--             : 10/26/1993  Angus Scott-Fleming
  1983. *--             :             replace cSafety w lSafety
  1984. *--             :             upper-case cStart
  1985. *--             :             minor bug fixes as noted by && <date>
  1986. *-- Calls.......: TempFile()       Function in FILES.PRG
  1987. *--               TextLine()       Function in FILES.PRG
  1988. *--               AAppend()        Function in FILES.PRG
  1989. *-- Called by...: Any
  1990. *-- Usage.......: GetInfo(<cKeyWord>,[<cKeyWord2>])
  1991. *-- Example.....: ? GetInfo("F5")
  1992. *-- Returns.....: Character expression
  1993. *-- Parameters..: cKeyWord  = Item you are looking for status of,
  1994. *--                           options listed return the following:
  1995. *--                    WORK    Number of current work area - whether
  1996. *--                            or not database is in use
  1997. *--                    PRINT   Current printer destination (PRN, NUL,
  1998. *--                            LPT1, COM1) as set by SET PRINTER TO.
  1999. *--                    ERROR   Error condition set by ON ERROR
  2000. *--                    ESCAPE  Escape condition set by ON ESCAPE
  2001. *--                    F2 to F10, Ctrl-F1 to Ctrl-F10, Shift-F1
  2002. *--                       to Shift-F10
  2003. *--                            The current setting of each key
  2004. *--                            as set by SET FUNCTION <label> TO
  2005. *--               OR
  2006. *--               cKeyWord, cKeyWord2 = Items you are checking the
  2007. *--                           status of, options return the following:
  2008. *--                    PAGE,LINE  Line number specified by ON PAGE AT
  2009. *--                               LINE in the page handling routine
  2010. *--                    HANDLE,<filename>  The handle number of the low-
  2011. *--                               level file specified by <filename>
  2012. *--                    NAME,<filehandle>  The file name of the low-
  2013. *--                               level file specified by <filehandle>
  2014. *--                    MODE,<filehandle>  The privilege of the low-
  2015. *--                               level file specified by <filehandle>
  2016. *----------------------------------------------------------------------
  2017.  
  2018.    parameters cKeyWord, cKeyWord2
  2019.    private cKey, l2Parms, cStart, lSafety, cTempTxt, nLines, cTmpArray
  2020.  
  2021.    cKey = upper(m->cKeyWord)
  2022.    l2Parms = (pcount() = 2)
  2023.  
  2024.    do case
  2025.       case m->cKey = "CTRL-" .or. m->cKey = "SHIFT" .or. ;
  2026.           (","+m->cKey+"," $ ",F2,F3,F4,F5,F6,F7,F8,F9,F10,")
  2027.           cStart = m->cKey + space(9 - len(m->cKey))+"-"
  2028.  
  2029.       case m->cKey = "PRINT"
  2030.          cStart = "Print Destination:"
  2031.  
  2032.       case m->cKey = "WORK"
  2033.          cStart = "Current work area ="
  2034.          if "" <> dbf()
  2035.             RETURN select(alias())
  2036.          endif
  2037.  
  2038.       case m->cKey = "ERROR"
  2039.          cStart = "On Error:"
  2040.  
  2041.       case m->cKey = "ESCAPE"
  2042.          cStart = "On Escape:"
  2043.  
  2044.       case m->cKey = "PAGE"
  2045.          cStart = "On Page At Line"
  2046.  
  2047.       case m->cKey = "HANDLE" .or. m->cKey = "NAME" .or. ;
  2048.            m->cKey = "MODE"
  2049.          cStart = "Low level files opened"
  2050.  
  2051.       otherwise      && none of the above
  2052.          RETURN ""
  2053.  
  2054.    endcase
  2055.  
  2056.    cTempTxt = TempFile()
  2057.    *-- get status info (into a temp file), which will then be parsed to
  2058.    *-- extract information requested ...
  2059.    set console off
  2060.    set alternate to &cTempTxt..  && create file without extension
  2061.                                  && double 'dot' is required
  2062.    set alternate on
  2063.    list status
  2064.    close alternate
  2065.    set console on
  2066.  
  2067.    nLines = TextLine(m->cTempTxt)
  2068.    aTmpArray = right(m->cTempTxt,8)
  2069.    cTmp = AAppend(m->cTempTxt,m->aTmpArray)
  2070.    nHandle = fopen(m->cTempTxt,"R")
  2071.    cResult = ""
  2072.  
  2073.    nX = 1
  2074.    cStart = upper(m->cStart)            && Tue  10-26-1993  upper case
  2075.    nStartLen = len(m->cStart)           && Tue  10-26-1993  pre-load LEN
  2076.    do while m->nX <= m->nLines
  2077.       if upper(left(&aTmpArray.[m->nX],m->nStartLen)) = m->cStart
  2078.          cResult = ltrim(substr(&aTmpArray.[m->nX],m->nStartLen+1))
  2079.          exit
  2080.       endif
  2081.       nX = m->nX + 1
  2082.    enddo
  2083.  
  2084.    *-- 2 parameters?
  2085.    if m->l2Parms .and. "" # m->cResult
  2086.       do case
  2087.          case m->cKey = "PAGE"
  2088.             if upper(m->cKeyWord2) = "LINE"
  2089.                cResult = left(m->cResult,at(" ",m->cResult) - 1)
  2090.             else
  2091.                cResult = substr(m->cResult,at(" ",m->cResult) + 1)
  2092.             endif
  2093.  
  2094.          case m->cKey = "HANDLE" .or. m->cKey = "NAME" .or. ;
  2095.               m->cKey = "MODE"
  2096.             cResult = ""
  2097.             nX = m->nX + 2
  2098.             do while val(&aTmpArray.[m->nX]) <> 0
  2099.                do case
  2100.                   case m->cKey = "HANDLE" .and. ;
  2101.                        upper(m->cKeyWord2) $ &aTmpArray.[m->nX]
  2102.                       cResult = str(val(&aTmpArray.[m->nX]))
  2103.  
  2104.                   case m->cKey = "NAME" .and. ;
  2105.                      m->cKeyWord2 = val(&aTmpArray.[m->nX])
  2106.                      cResult = substr(&aTmpArray.[m->nX],10,40)
  2107.  
  2108.                   case m->cKey = "MODE" .and. ;
  2109.                        m->cKeyWord2 = val(&aTmpArray.[m->nX])
  2110.                      cResult = substr(&aTmpArray.[m->nX],50,5)
  2111.                endcase
  2112.                if "" <> m->cResult
  2113.                   exit
  2114.                endif
  2115.                nX = m->nX + 1
  2116.             enddo
  2117.       endcase
  2118.    endif
  2119.  
  2120.    release &aTmpArray.
  2121.    nClose = fclose(m->nHandle)
  2122.    lSafety = set ("safety") = "ON"     && Tue  10-26-1993
  2123.    set safety off
  2124.    erase (m->cTempTxt + ".")
  2125.    if lSafety                           && Tue  10-26-1993  replace
  2126.       set safety ON                     && the dreaded macro expansion
  2127.    endif
  2128.    cResult = ltrim(rtrim(m->cResult))
  2129.  
  2130. RETURN iif(right(m->cResult,1) = ":",;
  2131.        left(m->cResult,len(m->cResult)-1),m->cResult)
  2132. *-- EoF: GetInfo()
  2133.  
  2134. FUNCTION TextLine
  2135. *----------------------------------------------------------------------
  2136. *-- Programmer..: Adam L. Menkes (Borland Technical Support)
  2137. *-- Date........: 04/01/1992
  2138. *-- Notes.......: Returns the number of lines of text in an ASCII Text
  2139. *--               File Taken from TechNotes, April, 1992
  2140. *-- Written for.: dBASE IV, 1.5
  2141. *-- Rev. History: 04/01/1992 -- Original
  2142. *-- Calls.......: None
  2143. *-- Called by...: Any
  2144. *-- Usage.......: TextLine(<cTextFile>)
  2145. *-- Example.....: ?TextLine("CONFIG.DB")
  2146. *-- Returns.....: Number of lines
  2147. *-- Parameters..: cTextFile = name of file
  2148. *----------------------------------------------------------------------
  2149.  
  2150.    parameter cTextFile
  2151.    private nLines, nHandle, cTemp, nClose
  2152.  
  2153.    nLines = 0
  2154.    if file(m->cTextFile)   && if it exists ...
  2155.       nHandle = fopen(m->cTextFile,"R")
  2156.       do while .not. feof(m->nHandle)
  2157.          cTemp = fgets(m->nHandle,254)
  2158.          nLines = m->nLines + 1
  2159.       enddo
  2160.       nClose = fclose(m->nHandle)
  2161.    endif
  2162.  
  2163. RETURN m->nLines
  2164. *-- EoF: TextLine()
  2165.  
  2166. FUNCTION TempFile
  2167. *----------------------------------------------------------------------
  2168. *-- Programmer..: Adam L. Menkes (Borland Technical Support)
  2169. *-- Date........: 04/01/1992
  2170. *-- Notes.......: Returns a random filename.
  2171. *-- Written for.: dBASE IV, 1.5
  2172. *-- Rev. History: 04/01/1992 -- Original
  2173. *-- Calls.......: none
  2174. *-- Called by...: Any
  2175. *-- Usage.......: TempFile([cFileExt])
  2176. *-- Example.....: cVarFile = TempFile("$XY")
  2177. *-- Returns.....: Filename
  2178. *-- Parameters..: cFileExt = optional parameter - allows you to assign
  2179. *--                          file extension to the end of the filename.
  2180. *----------------------------------------------------------------------
  2181.  
  2182.    parameters cFileExt
  2183.  
  2184. RETURN TempDir() + "TMP"+right(ltrim(str(rand(-1)*10000000)),5);
  2185.        +iif(pcount() = 0 .or. "" = m->cFileExt,"","."+m->cFileExt)
  2186. *-- EoF: TempFile()
  2187.  
  2188. FUNCTION AAppend
  2189. *----------------------------------------------------------------------
  2190. *-- Programmer..: Adam L. Menkes (Borland Technical Support)
  2191. *-- Date........: 10/26/1993
  2192. *-- Notes.......: Appends a text file into an array. This routine is
  2193. *--               limited to text files of 1,170 lines, and 254 char-
  2194. *--               acters per line. The text file must be an ASCII Txt
  2195. *--               formatted file. Taken from Technotes, April, 1992.
  2196. *-- Written for.: dBASE IV, 1.5
  2197. *-- Rev. History: 04/01/1992 -- Original
  2198. *--             : 10/26/1993 Angus Scott-Fleming release "ALL LIKE"
  2199. *-- Calls.......: TextLine()           Function in FILES.PRG
  2200. *-- Called by...: Any
  2201. *-- Usage.......: AAppend(<cFileName>,<aArrayName>)
  2202. *-- Example.....: ?AAppend("CONFIG.DB","aConfig")
  2203. *-- Returns.....: .T.
  2204. *-- Parameters..: cFileName  = Name of DOS Text file to read into array
  2205. *--               aArrayName = Name of array to create. If it already
  2206. *--                            exists, this array will be destroyed and
  2207. *--                            overwritten.
  2208. *----------------------------------------------------------------------
  2209.  
  2210.    parameters cFileName, aArrayName
  2211.    private aTArray, nLines, nX, nHandle
  2212.  
  2213.    *-- assign array name to a temp variable name ...
  2214.    aTArray = m->aArrayName
  2215.    *-- if it exists, get rid of it, and then re-define it
  2216.    *-- Tue  10-26-1993  original code release &aTArray. wasn't working
  2217.    release all like &aTArray.
  2218.    aTArray = m->aArrayName
  2219.    public  &aTArray.
  2220.    nLines = TextLine(m->cFileName)  && get number of lines
  2221.    declare &aTArray.[min(m->nLines,1170)]
  2222.  
  2223.    *-- get file handle
  2224.    nHandle = fopen(m->cFileName)
  2225.  
  2226.    *-- store the file into the array
  2227.    nX = 1
  2228.    do while m->nX <= m->nLines
  2229.       store fgets(m->nHandle,254) to &aTArray.[m->nX]
  2230.       nX = m->nX + 1
  2231.    enddo
  2232.  
  2233.    *-- close the file
  2234.    nHandle = fClose(m->nHandle)
  2235.  
  2236. RETURN .T.
  2237. *-- EoF: AAppend()
  2238.  
  2239. FUNCTION TempDir
  2240. *-------------------------------------------------------------------------------
  2241. *-- Programmer..: Adam L. Menkes (Borland Technical Support)
  2242. *-- Date........: 04/01/1992
  2243. *-- Notes.......: Returns path of temporary directory as set from DOS
  2244. *--               (i.e., SET DBTMP= ...) Taken from TechNotes, April, 1992
  2245. *-- Written for.: dBASE IV, 1.5
  2246. *-- Rev. History: 04/01/1992 -- Original
  2247. *-- Calls.......: none
  2248. *-- Called by...: Any
  2249. *-- Usage.......: TempDir()
  2250. *-- Example.....: ?TempDir()
  2251. *-- Returns.....: Path of temporary directory
  2252. *-- Parameters..: None
  2253. *-------------------------------------------------------------------------------
  2254.  
  2255.   cTempDir = iif("" <> GetEnv("DBTMP"),GetEnv("DBTMP"),GetEnv("TMP"))
  2256.  
  2257. RETURN cTempDir+iif(right(cTempDir,1)<> "\" .and.;
  2258.          left(os(),3) = "DOS" .and. .not. "" = cTempDir,"\","")
  2259. *-- EoF: TempDir()
  2260.  
  2261. *-----------------------------------------------------------------------
  2262. *-- EoP: MISC.PRG
  2263. *-----------------------------------------------------------------------
  2264.