home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / xbase / library / dbase / duflp / misc.prg < prev    next >
Text File  |  1992-07-13  |  37KB  |  991 lines
  1. *-------------------------------------------------------------------------------
  2. *-- Program...: MISC.PRG
  3. *-- Programmer: Ken Mayer (KENMAYER)
  4. *-- Date......: 06/25/1992
  5. *-- Notes.....: These are the miscellaneous functions/procedures from the PROC
  6. *--             file that aren't as commonly used as the others. See README.TXT
  7. *--             for details on how to use this library file.
  8. *--             The following functions have been copied from the appropriate
  9. *--             library files, and may be deleted if this program is simply
  10. *--             copied into the PROC.PRG file with STRINGS.PRG and CONVERT.PRG
  11. *--             files:
  12. *--             ATCOUNT() (from STRINGS.PRG)
  13. *--             DEC2HEX() (from CONVERT.PRG)
  14. *--             STRPBRK() (from STRINGS.PRG)
  15. *-------------------------------------------------------------------------------
  16.  
  17. FUNCTION PlayIt
  18. *-------------------------------------------------------------------------------
  19. *-- Programmer..: Mike Carlisle (A-T)
  20. *-- Date........: 01/21/1992
  21. *-- Notes.......: This function (from Technotes, issue??) will play a song
  22. *--               stored in a memory variable (array).
  23. *--               This is a two dimensional array, with the first dimension
  24. *--               defined being the # of notes, each note having two parts.
  25. *--               For a song with 12 notes, the declare statement is:
  26. *--                 DECLARE aSong[12,2]
  27. *--               aSong[1,1] is the pitch of the first note.
  28. *--               aSong[1,2] is the duration of the first note.
  29. *--               Pitches are defined from C below Middle C to B below Middle C.
  30. *--               These are from a "tempered" scale. Values can be raised an
  31. *--               octave by doubling the number, lowered by halving it.
  32. *--               Duration can be from 1 to 20.
  33. *--                           Note   Value
  34. *--                           C      261
  35. *--                           C#     277
  36. *--                           D      294
  37. *--                           D#     311
  38. *--                           E      329
  39. *--                           F      349
  40. *--                           F#     370
  41. *--                           G      392
  42. *--                           G#     415
  43. *--                           A      440
  44. *--                           A#     466
  45. *--                           B      494
  46. *-- Written for.: dBASE IV, 1.1
  47. *-- Rev. History: 01/21/1992 - Modified to allow use of parameter to choose
  48. *--               the song to be played. This alleviates the need for the
  49. *--               procedures SONG1 and SONG2 and the memfile created by them.
  50. *--               Two songs are provided (see below) ...
  51. *-- Calls.......: None
  52. *-- Called by...: Any
  53. *-- Usage.......: PlayIt(<nSong>)
  54. *-- Example.....: @5,10 say "Enter last name: " get lName valid required
  55. *--                      .not. empty(lName);
  56. *--                      error PlayIt(1)+"There must be a lastname ..."
  57. *--               Read
  58. *--                 && OR
  59. *--               ?? PlayIt(2)
  60. *-- Returns.....: Nul (or Beep on invalid parameter)
  61. *-- Parameters..: nSong = Song number. Programmer might consider adding to the
  62. *--                       list below for any songs added for documentation
  63. *--                       purposes ...
  64. *--                       VALID VALUES/SONGS:
  65. *--                         1  =  Dirge
  66. *--                         2  =  "Touchdown"
  67. *-------------------------------------------------------------------------------
  68.  
  69.     parameter nSong
  70.     private aSong, nCounter
  71.     
  72.     *-- check for valid type of parameter ... must be numeric ...
  73.     if .not. type("nSong") $ "NF"
  74.         return chr(7)
  75.     endif
  76.     
  77.     *-- get the integer value of nSong ... in case someone tries a "fast one"
  78.     nSong = int(nSong)
  79.     
  80.     *-- load song
  81.     do case
  82.         case nSong = 1  && dirge
  83.             declare aSong[12,2]          && 12 notes, 2 parts each
  84.             store 220     to aSong[1,1]  && pitch
  85.             store  10     to aSong[1,2]  && duration
  86.             store 220     to aSong[2,1]
  87.             store  10     to aSong[2,2]
  88.             store 220     to aSong[3,1]
  89.             store   2     to aSong[3,2]
  90.             store 220     to aSong[4,1]
  91.             store  10     to aSong[4,2]
  92.             store 261.63  to aSong[5,1]
  93.             store   7     to aSong[5,2]
  94.             store 246.94  to aSong[6,1]
  95.             store   2     to aSong[6,2]
  96.             store 246.94  to aSong[7,1]
  97.             store   5     to aSong[7,2]
  98.             store 220     to aSong[8,1]
  99.             store   5     to aSong[8,2]
  100.             store 220     to aSong[9,1]
  101.             store   5     to aSong[9,2]
  102.             store 205     to aSong[10,1]
  103.             store   5     to aSong[10,2]
  104.             store 220     to aSong[11,1]
  105.             store  15     to aSong[11,2]
  106.         case nSong = 2  && "touchdown"
  107.             declare aSong[7,2]           && 7 notes, 2 parts each
  108.             store 523.5   to aSong[1,1]  && pitch
  109.             store   2     to aSong[1,2]  && duration
  110.             store 587.33  to aSong[2,1]
  111.             store   2     to aSong[2,2]
  112.             store 659.29  to aSong[3,1]
  113.             store   2     to aSong[3,2]
  114.             store 783.99  to aSong[4,1]
  115.             store   7     to aSong[4,2]
  116.             store 659.29  to aSong[5,1]
  117.             store   2     to aSong[5,2]
  118.             store 783.99  to aSong[6,1]
  119.             store  10     to aSong[6,2]
  120.         otherwise                       && not song 1 or 2, return nothing
  121.             return chr(7)
  122.     endcase
  123.     
  124.     *-- playback
  125.     nCounter = 1
  126.     do while type("aSong[nCounter,1]") = "N"
  127.         set bell to aSong[nCounter,1],aSong[nCounter,2]
  128.         ?? chr(7) at col()
  129.         nCounter = nCounter + 1
  130.     enddo
  131.     set bell to  && return value to original
  132.  
  133. RETURN ""
  134. *-- EoF: PlayIt()
  135.  
  136. PROCEDURE PageEst
  137. *-------------------------------------------------------------------------------
  138. *-- Programmer..: Rachel Holmen (RAEHOLMEN)
  139. *-- Date........: 02/04/1992
  140. *-- Notes.......: This procedure estimates the number of pages needed for an 
  141. *--                output list. 
  142. *-- Written for.: dBASE IV, 1.1
  143. *-- Rev. History: 01/15/1992 - original procedure.
  144. *--               02/04/1992 - Ken Mayer - overhaul to allow the sending of
  145. *--               parameters for fields, rather than hard coding. Attempted to
  146. *--               make this a "black box" procedure.
  147. *-- Calls.......: CENTER               Procedure in PROC.PRG
  148. *--               SHADOW               Procedure in PROC.PRG
  149. *-- Called by...: Any
  150. *-- Usage.......: Do PageEst with <nCount>,"<cReport>",<nRecords>
  151. *-- Example.....: Use printers
  152. *--               Do PageEst with 0,"Printer for 'Hew' $ Brand",55
  153. *-- Returns.....: None
  154. *-- Parameters..: nCount   = record count for records to be printed ...
  155. *--                          if sent as "0", system will do a RECCOUNT() for you
  156. *--               cReport  = name of report, with any filters ... (FOR ...)
  157. *--               nRecords = number of records per page the report will handle.
  158. *--                          if sent as "0", system will assume 60 ...
  159. *-------------------------------------------------------------------------------
  160.  
  161.     parameters nCount,cReport,nRecords
  162.     private cReport2,nPos,nPage,cPage,cChoice,cCursor
  163.     
  164.     cReport2 = upper(cReport)
  165.     
  166.     *-- make sure we have a number of records to work with ...
  167.     if nCount = 0
  168.         if at("FOR",cReport2) > 0     && if a filter, extract the filter
  169.             npos = at("FOR",cReport2)  && so we can count records that match
  170.             cFilter = substr(cReport,Pos+3,len(cReport)-(npos-1))
  171.             count to nCount for &cFilter
  172.         else
  173.             nCount = reccount()
  174.         endif
  175.     endif
  176.     
  177.     if nRecords = 0
  178.         nRecords = 60
  179.     endif
  180.     
  181.     *-- calculate the number of pages for the report ...
  182.     store int(nCount/nRecords) to nPage
  183.     if mod(nCount,nRecords) > 45
  184.         store nPage+1 to nPage
  185.     else
  186.        store (nCount/nRecords) to nPage
  187.     endif
  188.     if nCount>0 .and. nCount < nRecords
  189.        store 1 to nPage
  190.     endif
  191.     
  192.     *-- deal with displaying info, and printing the report ...
  193.     save screen to sPrinter
  194.     activate screen            && in case there are other windows on screen ...
  195.     define window wPrinter from 8,15 to 15,65 double color rg+/gb,w/n,rg+/gb
  196.     do shadow with 8,15,15,65
  197.     activate window wPrinter
  198.     
  199.     *-- figure out how much to tell the user ...
  200.     if mod(nCount,nRecords) > 19 .and. mod(nCount,nRecords) < 46
  201.        store ltrim(str(nPage))+" and a half pages.)" to cPage
  202.     else
  203.        store ltrim(str(nPage))+" pages.)" to cPage
  204.     endif
  205.     
  206.     if nPage = 1
  207.        store "one page.)" to cPage
  208.     endif
  209.     
  210.     *-- display info ...
  211.     do center with 1,50,"",;
  212.         "There are "+ltrim(str(nCount))+" records."
  213.     do center with 2,50,"","(That's approximately "+cPage
  214.     
  215.     *-- ask if they want to generate the report?
  216.     store space(1) to cChoice
  217.     @4,8 say "Do you want to print the list? " get cChoice picture "!" ;
  218.         valid required cChoice $ "YN";
  219.         error chr(7)+"Enter 'Y' or 'N'!"
  220.     read
  221.     
  222.     *-- if yes, do it ...
  223.     if cChoice = "Y"
  224.         clear   && just this window ...
  225.         do center with 2,50,"","Align paper in your printer."
  226.         do center with 3,50,"","Press any key to continue ..."
  227.         x=inkey(0)
  228.         clear
  229.         do center with 2,50,"","... Printing ... do not disturb ..."
  230.         cCursor = set("CURSOR")
  231.         set cursor off
  232.         set console off
  233.         report form &cReport to print
  234.         set console on
  235.         set cursor &cCursor
  236.     endif
  237.     
  238.     *-- cleanup
  239.     deactivate window wPrinter
  240.     release window wPrinter
  241.     restore screen from sPrinter
  242.     release screen sPrinter
  243.  
  244. RETURN
  245. *-- EoP: PageEst
  246.  
  247. FUNCTION Permutes
  248. *-------------------------------------------------------------------------------
  249. *-- Programmer..: Jay Parsons (JPARSONS)
  250. *-- Date........: 03/01/1992
  251. *-- Notes.......: Permutations of nNum items taken Nhowmany at a time
  252. *--               That is, the number of possible arrangements, as
  253. *--               the different ways a president, V.P. and sec'y may
  254. *--               be chosen from a club of 10 members
  255. *-- Written for.: dBASE IV, 1.1
  256. *-- Rev. History: None
  257. *-- Calls.......: None
  258. *-- Called by...: Any
  259. *-- Usage.......: Permutes(<nNum>,<nHowMany>)
  260. *-- Example.....: ?Permutes(10,3)
  261. *-- Returns.....: Numeric
  262. *-- Parameters..: nNum     = number of items in the entire set
  263. *--               nHowMany = number to be used at once
  264. *-------------------------------------------------------------------------------
  265.  
  266.     parameters nNum, nHowmany
  267.     private nResult, nCounter
  268.     store 1 to nResult, nCounter
  269.     do while nCounter <= nHowmany
  270.       nResult = nResult * ( nNum + 1 - nCounter )
  271.       nCounter = nCounter + 1
  272.     enddo
  273.     
  274. RETURN nResult
  275. *-- EoF: Permutes()
  276.  
  277. FUNCTION Combos
  278. *-------------------------------------------------------------------------------
  279. *-- Programmer..: Jay Parsons (JPARSONS)
  280. *-- Date........: 03/01/1992
  281. *-- Notes.......: Combinations, similar to Permutations
  282. *--               Combinations treat "1, 3" as the same as
  283. *--               "3, 1", unlike permutations.  This gives the
  284. *--               games needed for a round robin and helps with
  285. *--               figuring odds of most state lotteries.
  286. *-- Written for.: dBASE IV, 1.1
  287. *-- Rev. History: None
  288. *-- Calls.......: None
  289. *-- Called by...: Any
  290. *-- Usage.......: Combos(<nNum>,<nHowMany>)
  291. *-- Example.....: ?Combos(10,2)
  292. *-- Returns.....: Numeric
  293. *-- Parameters..: nNum     = number of items in the entire set
  294. *--               nHowMany = number to be used at once
  295. *-------------------------------------------------------------------------------
  296.  
  297.     parameters nNum, nHowmany
  298.     private nResult, nCounter
  299.     store 1 to nResult, nCounter
  300.     do while nCounter <= nHowmany
  301.       nResult = nResult * ( nNum + 1 - nCounter ) / nCounter
  302.       nCounter = nCounter + 1
  303.     enddo
  304.     
  305. RETURN nResult
  306. *-- Combos()
  307.                                                           
  308. FUNCTION BinLoad
  309. *-------------------------------------------------------------------------------
  310. *-- Programmer..: Jay Parsons (JPARSONS)
  311. *-- Date........: 03/01/1992
  312. *-- Notes.......: Function to manage .bin files
  313. *--               A call to this function results in the following actions:
  314. *--          
  315. *--               If the name of a binary module alone is given as the argument,
  316. *--               the module is loaded if necessary, and .T. is returned.
  317. *--               If the file cannot be found, returns .F.
  318. *--               An error occurring during the load will cause a dBASE error.
  319. *--
  320. *--               If the argument "" is given, RELEASES all loaded modules and
  321. *--               returns .T.
  322. *--
  323. *--               If the argument contains the name of a loaded binary file
  324. *--               and "/R", RELEASEs that file only and returns .T.  If the
  325. *--               file is not listed in "gc_bins_in", returns .F.
  326. *--
  327. *--               This function uses the public variable "gc_bins_in".  It
  328. *--               keeps track of the modules loaded by changing the contents
  329. *--               of that variable.  If modules are loaded or released without
  330. *--               the use of this function, the variable will contain an
  331. *--               inaccurate list of the modules loaded and problems will
  332. *--               almost surely occur if this function is used later.
  333. *--
  334. *--               If more than 16 binary modules are requested over time through
  335. *--               this function, the one that was named least recently in a call
  336. *--               to load it by this function is released to make room for the
  337. *--               new one.  This will not necessarily be the module last used,
  338. *--               unless care is taken to use this function to "reload" the
  339. *--               .bin before each call.
  340. *--
  341. *--               Suggested syntax, to call the binary routine "Smedley.bin" 
  342. *--               which takes and returns two arguments:
  343. *-- 
  344. *--               IF binload( "Smedley" )
  345. *--                 CALL Smedley WITH Arg1, Arg2
  346. *--               ELSE
  347. *--                 ? "binary file not available"
  348. *--               ENDIF
  349. *-- Written for.: dBASE IV, 1.1
  350. *-- Rev. History: None
  351. *-- Calls.......: ATCOUNT()            Function in MISC.PRG
  352. *-- Called by...: Any
  353. *-- Usage.......: BinLoad(<cBinName>)
  354. *-- Example.....: ?BinLoad("Smedley")
  355. *-- Returns.....: Logical (.T. if successful )
  356. *-- Parameters..: cBinName = name of bin file to load ...
  357. *-------------------------------------------------------------------------------
  358.  
  359.     parameters cBinname
  360.    private cBin, nPlace, nTemp, lResult
  361.     cBin = ltrim( trim( upper( cBinname ) ) )
  362.     if type( "gc_bins_in" ) = "U"
  363.        public gc_bins_in
  364.        gc_bins_in = ""
  365.     endif
  366.    lResult = .T.
  367.    do case
  368.        case "" = cBin
  369.            do while "" # gc_bins_in
  370.               nPlace = at( "*", gc_bins_in )
  371.               cBin = left( gc_bins_in, nPlace - 1 )
  372.               gc_bins_in = substr( gc_bins_in, nPlace + 1 )
  373.               release module &cBin
  374.            enddo
  375.            release gc_bins_in
  376.        case "/R" $ cBinname
  377.            cBin = trim( left( cBin, at( cBin, "/" ) - 1 ) )
  378.           if "." $ cBin
  379.              cBin = left( cBin, at( ".", cBin ) - 1 )
  380.           endif
  381.           nPlace = at( cBin, gc_bins_in )
  382.            if nPlace = 0
  383.              lResult = .F.
  384.           else
  385.              gc_bins_in = substr( gc_bins_in, nPlace + 1 )
  386.              release module &cBin
  387.           endif
  388.        otherwise
  389.           if "." $ cBin
  390.              cBin = left( cBin, at( ".", cBin ) - 1 )
  391.           endif
  392.           if .not. file( cBin )
  393.              lResult = .F.
  394.           else
  395.              if atcount( "*", gc_bins_in ) > 15
  396.                 nPlace = at( "*", gc_bins_in )
  397.                 cTemp = left( gc_bins_in, nPlace - 1 )
  398.                 release module &cTemp
  399.                 gc_bins_in = substr( gc_bins_in, nPlace + 1)
  400.              endif
  401.              load &cBin
  402.              nPlace = at( cBin, gc_bins_in )
  403.              if Place > 0
  404.                 gc_bins_in = stuff( gc_bins_in, nPlace, len( cBin ) + 1, "" )
  405.              endif
  406.              gc_bins_in = gc_bins_in + cBin + "*"
  407.           endif
  408.    endcase
  409.  
  410. RETURN lResult
  411. *-- EoF: BinLoad()
  412.  
  413. FUNCTION DialUp
  414. *-----------------------------------------------------------------------
  415. *-- Programmer..: Jay Parsons (JPARSONS)
  416. *-- Date........: 06/17/1992
  417. *-- Notes.......: Dial the supplied telephone number.  Returns .F. for error.
  418. *--               This is not a full communications routine.  It is designed
  419. *--               to be used to place voice telephone calls, with the user
  420. *--               picking up the handset after using this function to dial.
  421. *--
  422. *--               This will work only with a modem using the standard Hayes
  423. *--               commands, and only if the port has already been set to the
  424. *--               desired baud rate, etc., by the DOS MODE command or 
  425. *--               otherwise.  If the port and dialing method are not constant
  426. *--               for the application, rewrite the function to accept them as
  427. *--               additional parameters.
  428. *--
  429. *-- Written for.: dBASE IV, 1.1, 1.5
  430. *-- Rev. History: 03/01/1992 - original function.
  431. *--               04/01/1992 - Jay Parsons - modified for Version 1.5.
  432. *--               04/03/1992 - Jay Parsons - ferror() call added.
  433. *--               06/17/1992 - Jay Parsons - 1.1 version changed to use
  434. *--                              SET PRINTER TO Device rather than .bin.
  435. *-- Calls       : Strpbrk()            Function in MISC.PRG
  436. *-- Called by...: Any
  437. *-- Usage.......: DialUp(<cPhoneNo>)
  438. *-- Example.....: x = DialUp( "555-1212" )
  439. *-- Returns.....: Logical (connect made or not)
  440. *-- Parameters..: cPhoneNo = Phone number to dial ...
  441. *-- Side effects: When used for versions before 1.1, sets the printer to
  442. *--             : a COM port and does not reset it.
  443. *-----------------------------------------------------------------------
  444.  
  445.    parameters cPhoneNo
  446.    private cNumber, cPort, cDialtype, cCallarg, xTemp, nHandle,;
  447.               cString, lResult
  448.    cPort = "Com2"          && specify Com1 or Com2 as required 
  449.    cDialtype = "Tone"      && specify Tone or Pulse ( rotary ) dialing
  450.    cNumber = cPhoneno
  451.    if type( "cPhoneno" ) $ "NF"
  452.       cNumber = ltrim( str( cPhoneno ) )
  453.    else
  454.       do while .t.
  455.          xTemp = Strpbrk( cNumber, " ()-" )
  456.          if xTemp = 0
  457.             exit
  458.          endif
  459.          cNumber = stuff( cNumber, xTemp, 1, "" )
  460.       enddo
  461.    endif
  462.    cString = "ATD" + upper( left( cDialtype, 1 ) ) + cNumber + chr(13 )
  463.    if val( substr( version(), 9, 5 ) ) < 1.5
  464.       SET PRINTER TO &cPort
  465.       ??? Cstring
  466.       lResult = .T.
  467.    else
  468.       nHandle = fopen( cPort, "w" )
  469.       if ferror() # 0
  470.          RETURN .F.
  471.       endif
  472.       lResult = ( fwrite( nHandle, cString ) = len( cString ))
  473.       xTemp = fclose( nHandle )
  474.    endif
  475.  
  476. RETURN lResult
  477. *-- EoF: Dialup()
  478.  
  479. FUNCTION CurrPort
  480. *-------------------------------------------------------------------------------
  481. *-- Programmer..: David P. Brown (RHEEM)
  482. *-- Date........: 03/22/1992
  483. *-- Notes.......: This procedure gets the current SET PRINTER TO information.
  484. *--               Will return a port or a filename if set to a file. This also
  485. *--               requires a DBF file called CURRPRT.DBF, with an MDX tag
  486. *--               set on the only field CURRPRT, which is a character field
  487. *--               of 80 characters.
  488. *--
  489. *--               Structure for database: CURRPRT.DBF
  490. *--               Number of data records:       0
  491. *--               Date of last update   : 03/22/92
  492. *--               Field  Field Name  Type       Width    Dec    Index
  493. *--                   1  CURRPRT     Character     80               Y
  494. *--               ** Total **                      81
  495. *--
  496. *-- Written for.: dBASE IV, 1.1
  497. *-- Rev. History: 03/18/1992 - original function.
  498. *--               03/18/1992 -- Ken Mayer (KENMAYER) to clean it up a bit, and
  499. *--               make it a function (not requiring the public memvar that
  500. *--               was originally required).
  501. *--               03/21/1992 -- David P. Brown (RHEEM) found bug while
  502. *--               selecting a previous work area (stored on cDBF).  Changed
  503. *--               'select cDBF' to 'select (cDBF)'.
  504. *--               03/22/1992 -- David P. Brown (RHEEM) final revision.  Added
  505. *--               check for no available work areas.  If none is available
  506. *--               then the program returns a null.
  507. *-- Calls.......: None
  508. *-- Called by...: Any
  509. *-- Usage.......: CurrPort()
  510. *-- Example.....: ? CurrPort()
  511. *-- Returns.....: the current port, as a character value
  512. *--               Port:   LPTx:, COMx:, PRN:
  513. *--               File:   Filename (with or without drive and path, depends
  514. *--                       on how the user entered it in the SET command)
  515. *--               Other:  Null (no work area available)
  516. *-- Parameters..: None
  517. *-------------------------------------------------------------------------------
  518.  
  519.    private cSafety, cConsole, cDBF, cPort
  520.  
  521.    *-- Check for available work area (safety check)
  522.    if select() = 0
  523.       return ""
  524.    endif
  525.    *-- Setup
  526.    cSafety = set("SAFETY")
  527.    set safety off
  528.    *-- so user can't see what's going on
  529.    cConsole = set("CONSOLE")
  530.    set console off
  531.    
  532.    if file("CURRPRT$.OUT")  && if this file exists
  533.       erase CURRPRT$.OUT    &&   delete it, so we can write on it
  534.    endif
  535.    
  536.    cDBF = alias()           && get current work area, so we can return ...
  537.    
  538.    *-- Get current printer
  539.    *-- note that we are not using 'Set Printer to file ...' due to the
  540.    *-- fact that this will change the info that the 'LIST STAT' command
  541.    *-- issues ...
  542.    set alternate to currprt$.out  && direct screen input to file
  543.    set alternate on
  544.    list status                    && returns environment information
  545.    set alternate off              && turn off 'capture'
  546.    close alternate                && close file 'currprt$.out'
  547.  
  548.    select select()                && grab next available work area ...
  549.    
  550.    use currprt order currprt excl && open database called CURRPRT
  551.    zap                            && clean out old copy of this file
  552.    
  553.    append from currprt$.out type sdf
  554.                                   && import the data for manipulation
  555.    
  556.    seek "Print"
  557.    *-- This is setup to do an indexed search, since the printer information
  558.    *-- will not always be on the same line. If it were, we could issue a
  559.    *-- 'GO <n>' command, which would speed up the routine. Somewhere on
  560.    *-- line 8 to 12 (or record) is 'Print destination: <port/file>'. The
  561.    *-- seek looks for the first word. The command below trims out the
  562.    *-- first part of the line, and extra spaces as well. This will
  563.    *-- return the information after the colon.
  564.    cPort = upper(trim(right(currprt,60))) && always in upper case
  565.    
  566.    *-- clean up
  567.    use
  568.    
  569.    if len(trim(cDBF)) > 0
  570.       select (cDBF)
  571.    else
  572.       select 1
  573.    endif
  574.    
  575.    *-- erase this file
  576.    erase currprt$.out 
  577.    
  578.    *-- return safety and console to previous states ...
  579.    set safety &cSafety
  580.    set console &cConsole
  581.    
  582. RETURN cPort
  583. *-- EoF: CurrPort()
  584.  
  585. FUNCTION FileLock
  586. *-------------------------------------------------------------------------------
  587. *-- Programmer..: Miriam Liskin
  588. *-- Date........: 04/27/1992
  589. *-- Notes.......: Taken from Miriam Liskin's dBASE IV, 1.1 Programming Book.
  590. *--               This routine modified by Ken Mayer to handle slightly
  591. *--               fancier processing ...
  592. *-- Written for.: dBASE IV, 1.1
  593. *-- Rev. History: 04/27/1992 -- Modified by Ken Mayer to give cleaner windows
  594. *--               and such.
  595. *-- Calls.......: CENTER               Procedure in PROC.PRG
  596. *--               SHADOW               Procedure in PROC.PRG
  597. *-- Called by...: Any
  598. *-- Usage.......: FileLock("<cColor>") 
  599. *-- Example.....: if FileLock("&cl_Wind1")
  600. *--                  *-- pack/reindex/whatever you need to do to database
  601. *--               else
  602. *--                  *-- do whatever processing necessary if file not
  603. *--                  *-- available for locking at this time
  604. *--               endif
  605. *-- Returns.....: Logical (.t./.f.)
  606. *-- Parameters..: cColor = Color combination for window ...
  607. *-------------------------------------------------------------------------------
  608.  
  609.     parameters cColor
  610.     private nCount,lLock,x,cCurNorm,cCurBox,cTempCol
  611.     
  612.     *-- deal with dBASE IV standard errors -- we don't want program bombing
  613.     on error ??
  614.     
  615.     *-- deal with screen stuff ...
  616.     *-- get it started ...
  617.     nCount = 1   && start at 1
  618.     lLock = .t.  && assume true
  619.     
  620.     *-- try 100 times
  621.     do while nCount <= 100 .and. .not. flock() .and. inkey() = 0
  622.         nCount = nCount + 1
  623.     enddo
  624.     
  625.     *-- if we can't lock the file, let the user know ...
  626.     if .not. flock()
  627.         lLock = .f.
  628.         save screen to sLock
  629.         *-- save colors
  630.         cCurNorm = colorof("NORMAL")
  631.         cCurBox  = colorof("BOX")
  632.         *-- set new colors
  633.         cTempCol = colorbrk(cColor,1)
  634.         set color of normal to &cTempCol
  635.         cTempCol = colorbrk(cColor,3)
  636.         set color of box to &cTempCol
  637.         *-- define window, display message
  638.         define window wLock from 10,15 to 18,65 double
  639.         do shadow with 10,15,18,65
  640.         activate window sLock
  641.         do center with 1,50,"","The file cannot be locked at this time"
  642.         do center with 2,50,"","Please try again."
  643.         x = inkey(0)
  644.         *-- cleanup
  645.         deactivate window wLock
  646.         release window wLock
  647.         restore screen from sLock
  648.         release screen sLock
  649.         *-- reset colors
  650.         set color of normal to &cCurNorm
  651.         set color of box    to &cCurBox
  652.     endif
  653.     
  654.     *-- clean up screen, etc.
  655.     on error
  656.     
  657. RETURN lLock
  658. *-- EoF: FileLock()
  659.  
  660. FUNCTION RecLock
  661. *-------------------------------------------------------------------------------
  662. *-- Programmer..: Miriam Liskin
  663. *-- Date........: 04/27/1992
  664. *-- Notes.......: Taken from Miriam Liskin's dBASE IV, 1.1 Programming Book.
  665. *--               This function attempts to lock current record in active
  666. *--               database. 
  667. *-- Written for.: dBASE IV, 1.1
  668. *-- Rev. History: 04/27/1992 -- Modified by Ken Mayer to give cleaner windows
  669. *--               and such.
  670. *-- Calls.......: CENTER               Procedure in PROC.PRG
  671. *--               SHADOW               Procedure in PROC.PRG
  672. *-- Called by...: Any
  673. *-- Usage.......: RecLock("<cColor>") 
  674. *-- Example.....: if RecLock("&cl_Wind1")
  675. *--                  *-- process record
  676. *--               else
  677. *--                  *-- return to menu, or whatever processing your routine
  678. *--                  *-- does at this point
  679. *--               endif
  680. *-- Returns.....: Logical (.t./.f.)
  681. *-- Parameters..: cColor = Color combination for window ...
  682. *-------------------------------------------------------------------------------
  683.  
  684.     parameters cColor
  685.     private nCount, lLock, cRetry, cCurNorm, cCurBox, cTempCol
  686.     
  687.     *-- deal with dBASE IV standard errors -- we don't want program bombing
  688.     on error ??
  689.     
  690.     *-- deal with screen
  691.     *-- start trying -- we will give the user the option to exit -- each time
  692.     *-- they unsuccessfully lock the record.
  693.     lLock = .t.   && assume true
  694.     do while .t.  && main loop
  695.         nCount = 1 && initialize each time we try ...
  696.         
  697.         *-- effectively a time-delay loop ...
  698.         do while nCount <= 100 .and. .not. rLock() .and. inkey() = 0
  699.             nCount = nCount + 1
  700.         enddo
  701.         
  702.         *-- if we CAN lock it, we're done, get outta here ...
  703.         if rlock()
  704.             lLock = .t.
  705.             exit
  706.         
  707.         else
  708.         
  709.             *-- otherwise, let the user know we couldn't do it, and ask if
  710.             *-- they want to try again ...
  711.             save screen to sLock
  712.             *-- save colors
  713.             cCurNorm = colorof("NORMAL")
  714.             cCurBox  = colorof("BOX")
  715.             *-- set new colors
  716.             cTempCol = colorbrk(cColor,1)
  717.             set color of normal to &cTempCol
  718.             cTempCol = colorbrk(cColor,3)
  719.             set color of box to &cTempCol
  720.             *-- define window ...
  721.             define window wLock from 10,15 to 18,65 double
  722.             do shadow with 10,15,18,65
  723.             activate window wLock
  724.             lLock = .f.
  725.             cRetry = 'N'
  726.             @1,3 say "This record is being updated at another"
  727.             @2,3 say "workstation. You can try again now,"
  728.             @3,3 say "to access the record, or return to it"
  729.             @4,3 say "later."
  730.             @6,3 say "Do you want to try again now? " get cRetry;
  731.                 picture "!";
  732.                 valid required cRetry $ "YN";
  733.                 error chr(7)+"Enter 'Y' or 'N'"
  734.             read
  735.             *-- cleanup
  736.             deactivate window wLock
  737.             release window wLock
  738.             restore screen from sLock
  739.             release screen sLock
  740.             *-- reset colors
  741.             set color of normal to &cCurNorm
  742.             set color of box    to &cCurBox
  743.             
  744.             if cRetry = "N"
  745.                 exit
  746.             endif  && cRetry = "N"
  747.             
  748.         endif  && rLock()
  749.         
  750.     enddo  && end of main loop
  751.     
  752.     *-- cleanup
  753.     on error
  754.  
  755. RETURN lLock
  756. *-- EoF: RecLock()
  757.  
  758. PROCEDURE DosShell
  759. *-------------------------------------------------------------------------------
  760. *-- Programmer..: Bowen Moursund
  761. *-- Date........: 06-10-1992
  762. *-- Notes.......: Swaps out dBASE from memory, loads a DOS shell
  763. *-- Written for.: dBASE IV v1.5
  764. *-- Rev. History: none
  765. *-- Calls.......: None
  766. *-- Called by...: Any
  767. *-- Usage.......: do DosShell with <cAppName>
  768. *-- Example.....: do DosShell with "MyApp"
  769. *-- Parameters..: cAppName - the name of the application
  770. *-------------------------------------------------------------------------------
  771.  
  772.     parameter cAppName
  773.      private cDir, lCursOff, cBatFile, nFH, nResult
  774.     cAppName = iif(pcount() = 0, "the application", cAppName)
  775.     private all
  776.     cDir = set("directory")
  777.     lCursOff = ( set("cursor") = "OFF" )
  778.     cBatFile = tempname("bat") + ".bat"
  779.     nFH = fcreate(cBatFile)
  780.     if nFH > 0
  781.         nBytes = fputs(nFH,"echo off")
  782.         nBytes = fputs(nFH,"cls")
  783.         nBytes = fputs(nFH,"echo " + chr(255))  && echo a blank line
  784.         nBytes = fputs(nFH,"echo NOTE: Enter EXIT to resume " + cAppName + ".")
  785.         nBytes = fwrite(nFH,getenv("comspec"))
  786.         null = fclose(nFH)
  787.         set cursor on
  788.         nResult = run(.f., cBatFile, .t.)
  789.         if nResult # 0
  790.             run &cBatFile
  791.         endif
  792.         erase (cBatFile)
  793.     else
  794.         cComSpec = getenv("comspec")
  795.         set cursor on
  796.         run &cComSpec.
  797.     endif
  798.     if lCursOff
  799.         set cursor off
  800.     endif
  801.     set directory to &cDir
  802.  
  803. RETURN
  804. *-- EoP: DosShell
  805.  
  806. FUNCTION IsDisk
  807. *-------------------------------------------------------------------------------
  808. *-- Programmer...: Ken Mayer (KENMAYER)
  809. *-- Date.........: 07/13/1992
  810. *-- Notes........: This routine is useful to check a drive for a valid disk in
  811. *--                in it (Valid means it is in the drive, with the door closed,
  812. *--                and is formatted ...). 
  813. *--                ***********************
  814. *--                ** REQUIRES DISK.BIN **
  815. *--                ***********************
  816. *-- Written for.: dBASE IV, 1.5
  817. *-- Rev. History: None
  818. *-- Called by...: None
  819. *-- Calls.......: CENTER               Procedure in PROC.PRG
  820. *--               SHADOW               Procedure in PROC.PRG
  821. *-- Usage.......: IsDisk(<cDrive>,<cMessCol>,<cErrCol>)
  822. *-- Example.....: IsDisk("cDrive","rg+/gb","rg+/r")
  823. *-- Returns.....: Logical
  824. *-- Parameters..: cDrive   = drive name -- single letter, no colon (i.e., "A")
  825. *--               cMessCol = color for message bonX
  826. *--               cErrCol  = color for error message
  827. *-------------------------------------------------------------------------------
  828.  
  829.     parameters cDrive, cMessCol, cErrCol
  830.  
  831.     private nX, cDrive2
  832.     
  833.     *-- deal with message window
  834.     save screen to sDisk
  835.     define window wDisk from 9,15 to 12,65 double color &cMessCol,,&cMessCol
  836.     do shadow with 9,15,12,65
  837.     activate window wDisk
  838.     *-- display message ...
  839.     do center with 0,50,"&cMessCol",;
  840.         "Place disk in drive "+cDrive+": and close drive door."
  841.     do center with 1,50,"&cMessCol",;
  842.         "Press any key when ready ..."
  843.     set cursor off
  844.     nX=inkey(0)
  845.     set cursor on
  846.     deactivate window wDisk
  847.     restore screen from sDisk
  848.  
  849.     *-- check for a valid drive. This uses the BIN file: DISK.BIN to do so.
  850.     load disk                 && load the BIN file
  851.     cDrive2 = cDrive          && save the current setting in case there's a prob.
  852.     call disk with cDrive2    && check to see if it's valid
  853.     define window wDisk from 7,10 to 14,70 double color &cErrCol,,&cErrCol
  854.     do while cDrive2 = 'X'    && perform loop if value of cDrive2 is 'X' (error)
  855.         do shadow with 7,10,14,70
  856.         activate window wDisk
  857.         do center with 0,60,"&cErrCol",;
  858.             "** DRIVE ERROR **"
  859.         do center with 2,60,"&cErrCol",;
  860.             "Check to make sure a valid (formatted) disk is in drive,"
  861.         do center with 3,60,"&cErrCol",;
  862.             "and that the drive door is closed properly."
  863.         do center with 5,60,"&cErrCol",;
  864.             "Press <Esc> to exit, any other key to continue ..."
  865.         set cursor off
  866.         nX=inkey(0)
  867.         set cursor on
  868.         deactivate window wDisk
  869.         restore screen from sDisk
  870.         if nX = 27                 && user pressed <Esc>
  871.             release module disk
  872.             release window wDisk
  873.             release screen sDisk
  874.             RETURN .F.
  875.         endif
  876.         cDrive2 = cDrive          && reset cDrive2 from original
  877.         call disk with cDrive2    && check for validity again ...
  878.     enddo
  879.  
  880.     *-- cleanup
  881.     release module Disk          && remove module from RAM so we can continue
  882.     restore screen from sDisk
  883.     release screen sDisk
  884.     release window wDisk
  885.  
  886. RETURN .t.
  887. *-- EoF: IsDisk()
  888.  
  889. *-------------------------------------------------------------------------------
  890. *-- The following are here as a courtesy ...
  891. *-------------------------------------------------------------------------------
  892.  
  893. FUNCTION AtCount
  894. *-------------------------------------------------------------------------------
  895. *-- Programmer..: Jay Parsons (JPARSONS)
  896. *-- Date........: 03/01/92
  897. *-- Notes.......: returns the number of times FindString is found in Bigstring
  898. *-- Written for.: dBASE IV
  899. *-- Rev. History: None
  900. *-- Calls.......: None
  901. *-- Called by...: Any
  902. *-- Usage.......: AtCount("<cFindStr>","<cBigStr>")
  903. *-- Example.....: ? AtCount("Test","This is a Test string, with Test data")
  904. *-- Returns.....: Numeric value
  905. *-- Parameters..: cFindStr = string to find in cBigStr
  906. *--               cBigStr  = string to look in
  907. *-------------------------------------------------------------------------------
  908.  
  909.     parameters cFindstr, cBigstr
  910.     private cTarget, nCount
  911.     
  912.     cTarget = cBigstr
  913.     nCount = 0
  914.     
  915.     do while .t.
  916.         if at( cFindStr,cTarget ) > 0
  917.             nCount = nCount + 1
  918.             cTarget = substr( cTarget, at( cFindstr, cTarget ) + 1 )
  919.         else
  920.          exit
  921.         endif
  922.     enddo
  923.     
  924. RETURN nCount
  925. *-- EoF: AtCount()
  926.     
  927. FUNCTION Dec2Hex
  928. *-------------------------------------------------------------------------------
  929. *-- Programmer..: Jay Parsons (JPARSONS)
  930. *-- Date........: 03/01/1992
  931. *-- Notes.......: Converts an integral number ( in decimal notation)
  932. *--               to a hexadecimal string
  933. *-- Written for.: dBASE IV, 1.1
  934. *-- Rev. History: None
  935. *-- Calls.......: None
  936. *-- Called by...: Any
  937. *-- Usage.......: Dec2Hex(<nDecimal>)
  938. *-- Example.....: ? Dec2Hex( 118 )
  939. *-- Returns.....: Character = Hexadecimal equivalent ( "F6" in example )
  940. *-- Parameters..: nDecimal = number to convert
  941. *-------------------------------------------------------------------------------
  942.     
  943.     parameters nDecimal
  944.     private nD, cH
  945.     nD = int( nDecimal )
  946.     cH= ""
  947.     do while nD > 0
  948.       cH = substr( "0123456789ABCDEF", mod( nD, 16 ) + 1 , 1 ) + cH
  949.       nD = int( nD / 16 )
  950.     enddo
  951.     
  952. RETURN iif( "" = cH, "0", cH )
  953. *-- Eof: Dec2Hex()
  954.  
  955. FUNCTION StrPBrk
  956. *-------------------------------------------------------------------------------
  957. *-- Programmer..: Jay Parsons (JPARSONS)
  958. *-- Date........: 03/01/92
  959. *-- Notes.......: Search string for first occurrence of any of the
  960. *--               characters in charset.  Returns its position as
  961. *--               with at().  Contrary to ANSI.C definition, returns
  962. *--               0 if none of characters is found.
  963. *-- Written for.: dBASE IV
  964. *-- Rev. History: None
  965. *-- Calls.......: None
  966. *-- Called by...: Any
  967. *-- Usage.......: StrPBrk("<cCharSet>","<cBigStr>")
  968. *-- Example.....: ? StrPBrk("Tt","This is a Test string, with Test data")
  969. *-- Returns.....: Numeric value
  970. *-- Parameters..: cCharSet = characters to look for in cBigStr
  971. *--               cBigStr  = string to look in
  972. *-------------------------------------------------------------------------------
  973.  
  974.     parameters cCharset, cBigstring
  975.     private nPos, nLooklen
  976.     nPos = 0
  977.     nLooklen = len( cBigstring )
  978.     do while nPos < nLooklen
  979.       nPos = nPos + 1
  980.         if at( substr( cBigstring, nPos, 1 ), cCharset ) > 0
  981.          exit
  982.        endif
  983.     enddo
  984.     
  985. RETURN iif(nPos=nLookLen,0,nPos)
  986. *-- EoF: StrPBrk()
  987.  
  988. *-------------------------------------------------------------------------------
  989. *-- EoP: MISC.PRG
  990. *-------------------------------------------------------------------------------
  991.