home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / xbase / library / dbase / duflp / files.prg < prev    next >
Text File  |  1992-07-24  |  55KB  |  1,402 lines
  1. *-------------------------------------------------------------------------------
  2. *-- Program...: FILES.PRG
  3. *-- Programmer: Ken Mayer (KENMAYER)
  4. *-- Date......: 06/25/1992
  5. *-- Notes.....: These are file processing routines. To see how to use this 
  6. *--             library file, see: README.TXT.
  7. *-------------------------------------------------------------------------------
  8.  
  9. PROCEDURE AllTags
  10. *-------------------------------------------------------------------------------
  11. *-- Programmer..: Susan Perschke (SPECDATA) and Michael Liczbanski (LMIKE)
  12. *-- Date........: 01/03/1992
  13. *-- Notes.......: Used to bring up a list of MDX tags on screen for the user,
  14. *--               so they can change the current tag ... This was gotten to me
  15. *--               by Steve (LTI), from "Data Based Advisor", December, 1991.
  16. *-- Written for.: dBASE IV, 1.1
  17. *-- Rev. History: 12/15/1991 - original procedure.
  18. *--               01/03/1992 - Ken Mayer -- added shadow ...
  19. *-- Calls.......: SHADOW               Procedure in PROC.PRG
  20. *-- Called by...: Any
  21. *-- Usage.......: DO AllTags WITH nULRow, nULCol
  22. *-- Example.....: ON KEY LABEL F8 DO ALLTAGS WITH 02,60
  23. *-- Returns.....: None
  24. *-- Parameters..: nULRow -- Starting Row for Popup
  25. *--               nULCol -- Starting Column for Popup
  26. *-------------------------------------------------------------------------------
  27.  
  28.     parameters nULRow, nULCol
  29.     private nBar, cPrompt, nBRRow, nBRCol
  30.     
  31.     *-- Disable left/right arrow keys to prevent an accidental exit
  32.     on key label leftarrow  ?? chr(7)
  33.     on key label rightarrow ?? chr(7)
  34.     
  35.     *-- Save current screen
  36.     save screen to sTag
  37.     
  38.     *-- define the popup
  39.     define popup pTag from nULRow, nULCol;
  40.        message " Press ENTER to select new index order...ESC to exit..."
  41.     nBar = 1                        && first bar
  42.     cPrompt    = "-No Index-"       &&  will always be this
  43.     
  44.     *-- loop to get the rest of 'em ...
  45.     do while "" <> cPrompt          && loop until no more tags
  46.         define bar nBar of pTag prompt (cPrompt)
  47.         cPrompt = tag(nBar)
  48.         nBar = nBar + 1
  49.     enddo
  50.     
  51.     on selection popup pTag deactivate popup
  52.     
  53.     *-- process shadow
  54.     nBRRow = nULRow+(nBar-1)+1 && bottom right for shadow (1 for t/b of pop)
  55.     nBRCol = nULCol+11         && bottom right for shadow (2 for sides,
  56.                                &&   +9 for tagnames)
  57.     do shadow with nULRow,nULCol,nBRRow,nBRCol
  58.     
  59.     *-- do it
  60.     activate popup pTag
  61.     
  62.     *-- Assign a null string to cPrompt if "No Index" selected
  63.     cPrompt = iif(bar() = 1, "",prompt())
  64.     
  65.     *-- Don't change index order if ESC pressed
  66.     if bar() <> 0
  67.        set order to (cPrompt)
  68.     endif
  69.     
  70.     *-- cleanup
  71.     release popup pTag
  72.     restore screen from sTag
  73.     release screen sTag
  74.     
  75.     *-- Enable left/right arrow keys
  76.     on key label leftarrow
  77.     on key label rightarrow
  78.  
  79. RETURN
  80. *-- EoP: AllTags
  81.  
  82. PROCEDURE MakeTagFl
  83. *-------------------------------------------------------------------------------
  84. *-- Programmer..: Bowen Moursund (BOWEN)
  85. *-- Date........: 04/15/1992
  86. *-- Notes.......: Build a .dbf file from scratch, without using CREATE FROM.
  87. *--               The file built has three fields, TAGS1, TAGS2 and TAGS3,
  88. *--               each character-type and 254 bytes wide.
  89. *-- Written for.: dBASE IV, 1.1
  90. *-- Rev. History: Broken out of other code and date-writing added
  91. *--               by Jay Parsons, 4/15/1992
  92. *--             : Originally from the program PRGCREAT.ZIP
  93. *-- Called by...: Any
  94. *-- Usage.......: do MakeTagFl WITH "<cFname>"
  95. *-- Example.....: do MakeTagFl WITH "Tags"
  96. *-- Returns.....: None
  97. *-- Parameters..: cFname, name of the .dbf to create
  98. *-- Side effects: Creates a .dbf and overwrites any existing one of same name
  99. *--             : Disables external setting of PRINTER
  100. *-------------------------------------------------------------------------------
  101.     parameters cFname
  102.     private cName
  103.     cName = cFname
  104.     if .not. "." $ cName
  105.        cName = cName + ".DBF"
  106.     endif
  107.     set printer to file ( cName )
  108.     set printer on
  109.     ??? "{3}"
  110.     ??? chr( year( date() - 1900 ) )
  111.     ??? chr( month( date() ) )
  112.     ??? chr( day( date() ) )
  113.     ??? "{0}{0}{0}{0}{129}{0}{251}{2}{0}{0}{0}{0}"
  114.     ??? "{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{201}{0}"
  115.     ??? "{84}{65}{71}{83}{49}{0}{0}{0}{0}{0}{0}{67}{0}{0}{0}{0}" && Tags1
  116.     ??? "{254}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}"
  117.     ??? "{84}{65}{71}{83}{50}{0}{0}{0}{0}{0}{0}{67}{0}{0}{0}{0}" && Tags2
  118.     ??? "{254}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}"
  119.     ??? "{84}{65}{71}{83}{51}{0}{0}{0}{0}{0}{0}{67}{0}{0}{0}{0}" && Tags3
  120.     ??? "{254}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}"
  121.     ??? "{13}{26}"
  122.     set printer off
  123.     set printer to
  124.  
  125. RETURN
  126. *-- EoP: MakeTagFl
  127.  
  128. PROCEDURE RedoTags
  129. *-------------------------------------------------------------------------------
  130. *-- Programmer..: David Love (DAVIDLOVE on the Borland Support Bulletin Board)
  131. *-- Date........: 04/18/1992
  132. *-- Notes.......: This routine is a "generic" MDX cleanup routine. It is useful
  133. *--               for handling "bloated" MDX files -- ones that have been around
  134. *--               awhile (they tend to be larger than necessary). This routine
  135. *--               will store the tag keys in an array, delete the tags, and then
  136. *--               rebuild the MDX file from scratch, keeping all tag names and
  137. *--               keys, and the MDX SHOULD be smaller.
  138. *--             : Will act on the dbf's production mdx (ie. same name as dbf)
  139. *-- Written for.: dBASE IV, 1.5
  140. *-- Rev. History: 01/20/1992 - original function for dBASE IV Ver. 1.1.
  141. *--               04/18/1992 - David Love - adapted for use with beta version
  142. *--               of dBASE IV, version 1.5.
  143. *--               (TAGCOUNT(), FOR(), DESCENDING(), UNIQUE() are 1.5 functions)
  144. *-- Calls.......: None
  145. *-- Called by...: Any
  146. *-- Usage.......: do RedoTags with "<cDBF>"
  147. *-- Example.....: do RedoTags with "Referral"
  148. *-- Returns.....: None
  149. *-- Parameters..: cDBF = Name of DATABASE file, no extension necessary.
  150. *-------------------------------------------------------------------------------
  151.  
  152.     parameter cDBF
  153.     
  154.     use (cDBF)
  155.     
  156.     *-- First, figure out how many tags exist
  157.  
  158.     private nMaxTags
  159.     nMaxTags = tagcount( cDBF,1 )
  160.     
  161.     *-- only perform routine if an index tag exists
  162.     if nMaxTags > 0
  163.       private nTags, mkey, mtag
  164.     
  165.       *-- store the keys and tags to an array
  166.       declare aTags[nMaxTags,5]
  167.        nTags = 1
  168.       do while nTags <= nMaxTags
  169.         store key( (cDBF),nTags) to aTags[nTags,1]        && grab the key
  170.         store tag( (cDBF),nTags) to aTags[nTags,2]        && grab the tagname
  171.         store for( (cDBF),nTags) to aTags[nTags,3]        && grab the for clause
  172.         store descending( (cDBF),nTags) to aTags[nTags,4] && .t. if descending
  173.         store unique( (cDBF),nTags) to aTags[nTags,5]     && .t. if unique
  174.         nTags = nTags + 1
  175.       enddo
  176.     
  177.        *-- now, delete the tags   
  178.        do while "" # tag( (cDBF),1)
  179.          delete tag tag( (cDBF),1)
  180.        enddo
  181.       
  182.        *-- rebuild the MDX, tag by tag ...
  183.        nTags = 1
  184.       do while nTags <= nMaxTags
  185.         mkey = aTags[nTags,1]+iif(""#aTags[nTags,3]," for "+aTags[nTags,3],"") ;
  186.           + iif(aTags[nTags,4]," DESCENDING","") ;
  187.           + iif(aTags[nTags,5]," UNIQUE","")
  188.          mtag = aTags[nTags,2]
  189.         index on &mkey. tag &mtag.
  190.          nTags = nTags + 1
  191.       enddo
  192.     
  193.        *-- release the array ...
  194.       release aTags
  195.     
  196.     endif  && check for tags ...
  197.     use    && close database
  198.     
  199. RETURN
  200. *-- EoP: RedoTags
  201.  
  202. PROCEDURE AutoRedo
  203. *------------------------------------------------------------------------------
  204. *-- Programmer..: Douglas P. Saine (XRED)
  205. *-- Date........: 03/06/1992
  206. *-- Notes.......: Displays a popup to choose a DBF from the current directory
  207. *--               to re-build its MDX file
  208. *-- Written for.: dBASE IV, 1.1
  209. *-- Rev. History: 03/04/1992 - original procedure.
  210. *--               03/06/1992 -- Ken Mayer (KENMAYER) added color parameter,
  211. *--                shadow to popup, and erase DBFS.DBF datafile at end.
  212. *-- Calls.......: LISTDBFS             Procedure in FILES.PRG
  213. *--               REDOTAGS             Procedure in FILES.PRG
  214. *--               CENTER               Procedure in PROC.PRG
  215. *--               YESNO2()             Function in PROC.PRG
  216. *--               SHADOW               Procedure in PROC.PRG       
  217. *--               EXTRCLR()            Function in PROC.PRG
  218. *-- Called by...: Any
  219. *-- Usage.......: do AutoRedo with nXTL,nYTL,nXBR,nYBR,cColor
  220. *-- Example.....: do AutoRedo with 5,34,15,47,"rg+/gb,w+/n,rg+/gb"
  221. *-- Returns.....: None
  222. *-- Parameters..: None
  223. *------------------------------------------------------------------------------
  224.  
  225.     parameters nXTL, nYTL, nXBR, nYBR, cColor
  226.     
  227.     *-- Save Environment
  228.     cTalk = set("talk")
  229.     cStat = set("status")
  230.     cCloc = set("clock")
  231.     cScor = set("scoreboard")
  232.     cSafe = set("safety")
  233.     
  234.     *-- Set Environment
  235.     set stat off
  236.     set talk off
  237.     set cloc off
  238.     set scor off
  239.     set safe off
  240.     
  241.     *-- Full Screen Window for screen restoration when finished
  242.     define window wCoverScr from 0,0 to 23,79 none
  243.     activate window wCoverScr
  244.     clear
  245.     
  246.     *-- Make a Data File of the Current Directory
  247.     do center with 10,80,extrclr('&cColor'),;
  248.             '... Making Data File from Current Directory ...'
  249.     do ListDBFs
  250.     
  251.     use DBFS
  252.     index on DBFS->DBF tag IORDER
  253.     
  254.     *-- Define and access the popup of DataFiles
  255.     define popup uDbfList from nXTL,nYTL to nXBR,nYBR prompt field DBFS->DBF
  256.     on selection popup uDbfList deactivate popup
  257.     
  258.     *-- Execute loop for multiple re-indexes
  259.     clear
  260.     lLoop = .t.
  261.     do while lLoop
  262.         do shadow with nXTL,nYTL,nXBR,nYBR
  263.        activate popup uDbfList
  264.         clear  && get rid of shadow
  265.         
  266.        *--  Record the prompt() and remove '.dbf' so it works with Redotag
  267.        cDataFile = substr(prompt(),1,len(trim(prompt()))-4)
  268.     
  269.        *-- Verify the MDX exists
  270.        if file(cDataFile+'.mdx')
  271.           do redotags with cDataFile
  272.        else
  273.           do center with 10,80,extrclr("&cColor"),;
  274.             '... Production MDX file not found for file '+cDataFile
  275.           n = inkey(0)
  276.           clear
  277.        endif
  278.     
  279.        *-- Determine if the user wants to re-build another
  280.        if YesNo2(.t.,"CC","",;
  281.           "Do you wish to reindex another file?","","&cColor")
  282.           use DBFS order IORDER
  283.        else
  284.           lLoop = .f.
  285.        endif
  286.     
  287.     enddo
  288.     
  289.     *-- Restore environment
  290.     use DBFS
  291.     delete tag IORDER
  292.     use
  293.     erase DBFS.DBF
  294.     release popup uDbfList
  295.     deactivate window wCoverScr
  296.     release window wCoverScr
  297.     set stat &cStat
  298.     set talk &cTalk
  299.     set cloc &cCloc
  300.     set scor &cScor
  301.     set safe &cSafe
  302.     
  303. RETURN
  304. *-- EoP:  AutoRedo
  305.  
  306. PROCEDURE PrntTags
  307. *-------------------------------------------------------------------------------
  308. *-- Programmer..: David Love (DAVIDLOVE)
  309. *-- Date........: 04/18/1992
  310. *-- Notes.......: This routine is a "quick and not-so-dirty" method of printing
  311. *--               the tag and key expressions for a dbf's production mdx file.
  312. *--               It obviates the need for DISP/LIST STAT TO PRINT (or DISP STAT
  313. *--               followed by SHIFT+PrtScr).
  314. *--               This code is modified from the procedure RedoTags.prg,
  315. *--               previously posted on the BORBBS.
  316. *--             : The proc will print the full key expression, including
  317. *--               FOR/DESCENDING/UNIQUE options, if present.
  318. *-- Written for.: dBASE IV, 1.1
  319. *-- Rev. History: 01/31/1992 - original procedure written for dBASE IV, Ver. 1.1
  320. *--               04/18/1992 - David Love - revised for version 1.5
  321. *-- Calls.......: None
  322. *-- Called by...: Any
  323. *-- Usage.......: do PrntTags with "<cDBF>"
  324. *-- Example.....: do PrntTags with "Referral"
  325. *-- Returns.....: None
  326. *-- Parameters..: cDBF = Name of DATABASE file, no extension necessary.
  327. *-------------------------------------------------------------------------------
  328.  
  329.     parameter cDBF
  330.     
  331.     use (cDBF)
  332.     
  333.     *-- First, figure out how many tags exist
  334.  
  335.     private nMaxTags
  336.     nMaxTags = tagcount( cDBF,1 )
  337.     
  338.     *-- only perform routine if an index tag exists
  339.     if nMaxTags > 0
  340.       private nTags, mkey, mtag
  341.     
  342.       *-- store the keys and tags to an array
  343.       declare aTags[nMaxTags,5]
  344.        nTags = 1
  345.       do while nTags <= nMaxTags
  346.         store key( (cDBF),nTags) to aTags[nTags,1]        && grab the key
  347.         store tag( (cDBF),nTags) to aTags[nTags,2]        && grab the tagname
  348.         store for( (cDBF),nTags) to aTags[nTags,3]        && grab the for clause
  349.         store descending( (cDBF),nTags) to aTags[nTags,4] && .t. if descending
  350.         store unique( (cDBF),nTags) to aTags[nTags,5]     && .t. if unique
  351.          nTags = nTags + 1
  352.       enddo
  353.     
  354.       *-- print each tag with it's key expression
  355.       private cTalk
  356.       cTalk = set("TALK")
  357.       set talk off
  358.       set printer on
  359.       ?? "DATABASE: "+cDBF AT 0
  360.       ?
  361.       ?? "TAG" at 0
  362.       ?? "KEY EXPRESSION" AT 12
  363.       ?
  364.       nTags = 1
  365.       do while nTags <= nMaxTags
  366.         ?? aTags[nTags,2] AT 0
  367.         ?? aTags[nTags,1] + ;
  368.           iif(""#aTags[nTags,3]," FOR "+aTags[nTags,3],"") + ;
  369.           iif(aTags[nTags,4]," DESCENDING","") + ;
  370.           iif(aTags[nTags,5]," UNIQUE","") AT 12
  371.         ?
  372.         nTags = nTags + 1
  373.       enddo
  374.       ?
  375.       set printer off
  376.       set talk &cTalk.
  377.  
  378.       *-- release the array ...
  379.       release aTags
  380.     
  381.     endif  && check for tags ...
  382.     use    && close database
  383.     
  384. RETURN
  385. *-- EoP: PrntTags
  386.  
  387. PROCEDURE ListDBFs
  388. *-------------------------------------------------------------------------------
  389. *-- Programmer..: David Love (DAVIDLOVE)
  390. *-- Date........: 01/31/1992
  391. *-- Notes.......: This procedure will create a list of the database (.dbf) files
  392. *--               in the current directory.  It will create a database file
  393. *--               named Dbfs.dbf which exists of one 12-character field--Dbf.
  394. *--               It will also create a text file, Dbfs.txt, through the
  395. *--               LIST FILES to FILE command.  Then it will append records
  396. *--               to the Dbfs.dbf file and erase the Dbfs.txt file.
  397. *--             : This Dbfs.dbf file can be SCANned, or used in a POPUP PROMPT
  398. *--               FIELD command, or in any way that you can imagine.
  399. *--             : The file 'Dbfs.dbf' will not be included in the Dbfs.dbf file.
  400. *-- WARNING===> : If your application includes a file with the name of
  401. *--               'Dbfs.dbf', it will be overwritten with the file created
  402. *--                by this procedure.
  403. *-- Written for.: dBASE IV, 1.1
  404. *-- Rev. History: None
  405. *-- Calls.......: None
  406. *-- Called by...: Any
  407. *-- Usage.......: do ListDBFs
  408. *-- Example.....: do ListDBFs
  409. *-- Returns.....: None
  410. *-- Parameters..: None
  411. *-------------------------------------------------------------------------------
  412.  
  413.    private cConsole
  414.    *-- Write the directory of dbf files to a text file (Dbfs.txt)
  415.    *-- First, erase the file if it exists
  416.    if file("Dbfs.txt")
  417.      erase dbfs.txt
  418.    endif
  419.  
  420.    *-- And, erase the dbfs.dbf file if it exists (so won't be included
  421.    *-- in the list)
  422.    if file("Dbfs.dbf")
  423.      erase Dbfs.dbf
  424.    endif
  425.  
  426.    *-- Now, write the dbfs.txt file
  427.    cConsole = set("CONSOLE")
  428.    set console off
  429.    list files to file dbfs.txt
  430.    set console &cConsole.
  431.  
  432.    *-- Then, create the file DBFS.DBF
  433.     *-- Acknowledgement..: Bowen Moursund for the code that creates Dbfs.dbf
  434.     *--                    (Download PRGCREAT.ZIP from BORBBS for more info.)
  435.    set printer to file DBFS.DBF
  436.    set printer on
  437.    ??? "{3}{92}{2}{1}{0}{0}{0}{0}{65}{0}{13}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}"+;
  438.    "{0}{0}{0}{0}{0}{0}{0}{0}{89}{0}{68}{66}{70}{0}{0}{0}{0}{0}{0}{0}{0}{67}{3}"+;
  439.    "{0}{44}{85}{12}{0}{0}{0}{1}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{13}{26}"
  440.    set printer to
  441.    set printer off
  442.  
  443.    *-- Now, append dbfs.txt to dbfs.dbf if the record is a dbf listing.
  444.    use Dbfs
  445.    append from Dbfs.txt for ".DBF" $ Dbf type sdf
  446.  
  447.    use    && can remove this command if you want
  448.  
  449.    erase Dbfs.txt            && don't need it anymore
  450.  
  451. RETURN
  452. *--EOP: ListDBFs
  453.  
  454. FUNCTION Recompile
  455. *-------------------------------------------------------------------------------
  456. *-- Programmer..: Jay Parsons (Jparsons)
  457. *--             : Adapted from Compall.prg and Compall2.prg, by James Thomas.
  458. *-- Date........: 04/16/1992
  459. *-- Notes.......: Recompiles all dBASE source-code files.  Takes three
  460. *--             : optional parameters:
  461. *--             :    Directory to recompile.  Default is current directory.
  462. *--             :    Skeleton to recompile.  Default is all of .PRG, .LBG,
  463. *--             :       .FRG, .PRS, .FMT, .QBE and .UPD files.  If a skeleton
  464. *--             :       is provided that matches files that are not dBASE
  465. *--             :       source-code files, compiler errors will occur and,
  466. *--             :       in the absence of external error handling, see below,
  467. *--             :       suspend processing.
  468. *--             :    "Runtime" or any characters starting with "R" or "r" to
  469. *--             :       direct the compilation be with the "RUNTIME" option.
  470. *--             : Does not recompile a file if a file of the same root name,
  471. *--             : an .??O extension and a later timestamp resides in the
  472. *--             : directory.
  473. *--             : Renames compilations of FMT, FRG, LBG and QBO files to ??O.
  474. *--             : Returns .T. if successful, or .F.
  475. *--             :
  476. *--             : Listing of compilation errors requires SET ALTERNATE TO,
  477. *--             : and trapping such errors as passing the name of a file
  478. *--             : that does not contain dBASE source code to the COMPILE
  479. *--             : command requires an ON ERROR trap.  These are omitted here
  480. *--             : due to lack of ways to prevent the function from changing
  481. *--             : these settings externally.  Lines needed to have any
  482. *--             : compilation errors print to the alternate file are included
  483. *--             : as comments.
  484. *--             :
  485. *-- Written for.: dBASE IV Version 1.5.
  486. *--             : Adaptation to a prior release may require changing the
  487. *--             : way parameters are handled, and also rewriting the lines
  488. *--             : that use fdate() and ftime() to read timestamps.
  489. *-- Rev. History: 04/07/1992 - original function.
  490. *--             : 04/13/1992 - additional environment settings.
  491. *--             : 04/16/1992 - aliases added thanks to BOWEN.
  492. *--             : 06-10-1992 - a few minor bug fixes
  493. *-- Calls       : Makestru()            FUNCTION in FILES.PRG
  494. *-- Called by...: Any
  495. *-- Usage.......: Recompile ( [<cDir>] [,<cSkel> [,"R"]] )
  496. *-- Example.....: ? Recompile ( "\dBASE\Myprogs", "*.??G" )
  497. *-- Parameters..: cDir, a DOS directory name ( and path if needed )
  498. *--             : cSkel, skeleton using wildcards for files to compile
  499. *--             : cRun, "R" or "r" if compilation is for Runtime
  500. *-- Side effects: Creates compiled .??O files, overwriting any of the same
  501. *--             : root names that may exist.
  502. *-------------------------------------------------------------------------------
  503.  
  504.    parameters cDirectry, cSkeleton, cRun
  505.    private cCons, cAlias, cAlt, cDir, cSafety, cTempfile,;
  506.        cSrcfile, cObjfile, cString1, cString2, cRunopt
  507.  
  508.    * preserve environment
  509.    cCons = set( "CONSOLE" )
  510.    SET CONSOLE OFF
  511.    cAlias = alias()
  512.    cAlt = set( "ALTERNATE" )
  513.    SET ALTERNATE OFF
  514.    cDir = set( "DIRECTORY" )
  515.    IF type( "cDirectry" ) = "C" .AND. "" # cDirectry
  516.       SET DIRECTORY TO &cDirectry
  517.    ENDIF
  518.    cSafety = set( "SAFETY" )
  519.    SET SAFETY OFF
  520.    SELECT select()
  521.  
  522.    * make temporary structure file and fill in the DOS DIR listing structure
  523.    cTempfile = Makestru()
  524.    USE ( cTempfile ) ALIAS cTempfile
  525.    APPEND BLANK
  526.    REPLACE FIELD_NAME WITH "FILENAME", FIELD_TYPE WITH "C", FIELD_LEN WITH 9, ;
  527.            FIELD_DEC WITH 0, FIELD_IDX WITH "N"
  528.    APPEND BLANK
  529.    REPLACE FIELD_NAME WITH "EXT", FIELD_TYPE WITH "C", FIELD_LEN WITH 4, ;
  530.            FIELD_DEC WITH 0, FIELD_IDX WITH "N"
  531.    APPEND BLANK
  532.    REPLACE FIELD_NAME WITH "FLENGTH", FIELD_TYPE WITH "C", FIELD_LEN WITH 10, ;
  533.            FIELD_DEC WITH 0, FIELD_IDX WITH "N"
  534.    APPEND BLANK
  535.    REPLACE FIELD_NAME WITH "TIMESTAMP", FIELD_TYPE WITH "C", FIELD_LEN WITH 16, ;
  536.            FIELD_DEC WITH 0, FIELD_IDX WITH "N"
  537.  
  538.    * make .dbf for source file names, reset and return if error occurs
  539.    cSrcfile = cTempfile
  540.    DO WHILE file ( cSrcfile + ".DBF" )
  541.       cSrcfile  = "TMP" + ltrim( str( rand() * 100000, 5 ) )
  542.    ENDDO
  543.    CREATE ( cSrcfile ) FROM  ( cTempfile )
  544.    USE ( cSrcfile ) alias cSrcfile
  545.  
  546.    IF "" = alias()
  547.      ERASE ( cTempfile +".DBF" )
  548.      SET DIRECTORY TO &cDir
  549.      SET ALTERNATE &cAlt
  550.      IF "" # cAlias
  551.         SELECT ( cAlias )
  552.      ENDIF
  553.      SET CONSOLE &cCons
  554.      RETURN .F.
  555.    ENDIF
  556.  
  557.    * and for object file names
  558.    SELECT select()
  559.    USE ( cTempfile ) ALIAS cTempfile
  560.    GO 1
  561.    REPLACE FIELD_IDX WITH "Y"
  562.    cObjfile = cSrcfile
  563.    DO WHILE file ( cObjfile + ".DBF"  )
  564.       cObjfile  = "TMP" + ltrim( str( rand() * 100000, 5 ) )
  565.    ENDDO
  566.    CREATE ( cObjfile ) FROM (cTempfile)
  567.    use ( cObjfile ) alias cObjfile order filename
  568.    IF "" = alias()
  569.       ERASE ( cTempfile + ".DBF" )
  570.       SELECT cSrcfile
  571.       USE
  572.       ERASE ( cSrcfile + ".DBF" )
  573.       SET DIRECTORY TO &cDir
  574.       SET ALTERNATE &cAlt
  575.       IF "" # cAlias
  576.          SELECT  ( cAlias )
  577.       ENDIF
  578.       SET CONSOLE &cCons
  579.       RETURN .F.
  580.    ENDIF
  581.  
  582.    * reuse name of cTempfile as SDF; DIR names of source files to it and append
  583.    cString1 = cTempfile + ".DBF"
  584.  
  585.    RUN dir *.* > &cString1
  586.    SELECT  cSrcfile
  587.    APPEND FROM ( cString1 ) TYPE SDF
  588.  
  589.    * delete directory entries not for source files of desired name or type
  590.    IF type("cSkeleton") = "C" .AND. "" # cSkeleton
  591.       DELETE ALL FOR .NOT. like( upper( cSkeleton ), trim( Filename ) +"." ;
  592.             + trim( Ext ) )
  593.    ELSE
  594.       DELETE ALL FOR .NOT. Ext $ "PRG LBG FRG PRS FMT QBE UPD "
  595.    ENDIF
  596.    PACK
  597.  
  598.    * reuse again for .??O files
  599.    RUN dir *.??o > &cString1
  600.    SELECT cObjfile
  601.    APPEND FROM ( cString1 ) TYPE SDF
  602.    DELETE ALL FOR left( Filename, 1 ) = " " .OR. right( Ext, 2 ) # "O "
  603.    PACK
  604.    ERASE ( cString1 )
  605.  
  606.    * assemble Runtime option
  607.    cRunopt = iif( type( "cRun" ) = "C" .AND. "" # cRun ;
  608.            .AND. left( cRun, 1 ) $ "Rr", " RUNTIME", "" )
  609.  
  610.    * now compile all the files that need it
  611.    SELECT cSrcfile
  612.    SCAN
  613.       cString1 = trim( Filename ) + "." + trim( Ext )
  614.       *   Is there an object file of this name?
  615.       IF Seek( Filename, "cObjfile" )
  616.          cString2 = trim( cObjfile->Filename ) + "." + trim( cObjfile->Ext )
  617.          cString2 = dtos( fdate( cString2 ) ) + ftime( cString2 )
  618.          *   then check timestamps and skip it if already compiled
  619.          IF dtos( fdate( cString1 ) ) + ftime( cString1 ) < cString2
  620.             LOOP
  621.          ENDIF
  622.       ENDIF
  623.       *   compile it otherwise, listing errors if enabled
  624.       cString2 = cString1 + cRunopt
  625.       * SET ALTERNATE ON
  626.       * ? "Compiling " + cString2
  627.       COMPILE &cString2
  628.       * ?
  629.       * SET ALTERNATE OFF
  630.       *   and rename object files that should not be .DBOs
  631.       IF Ext $ "FMT FRG LBG QBE "
  632.          cString2 = stuff( cString1, len( cString1 ), 1, "O" )
  633.          IF file( cString2 )
  634.             ERASE ( cString2 )
  635.          ENDIF
  636.          cString1 = trim( Filename ) + ".DBO"
  637.          RENAME ( cString1 ) TO ( cString2 )
  638.       ENDIF
  639.    ENDSCAN
  640.  
  641.    *  Clean up
  642.    USE
  643.    ERASE ( cSrcfile + ".DBF" )
  644.    SELECT cObjfile
  645.    USE
  646.    ERASE ( cObjfile + ".DBF" )
  647.    ERASE ( cObjfile + ".MDX" )
  648.    SET SAFETY &cSafety
  649.    SET DIRECTORY TO &cDir
  650.    SET ALTERNATE &cAlt
  651.    IF "" # cAlias
  652.      SELECT ( cAlias )
  653.    ENDIF
  654.    SET CONSOLE &cCons
  655.  
  656. RETURN .T.
  657. *-- Eof() Recompile
  658.  
  659. PROCEDURE Makedbf
  660. *-------------------------------------------------------------------------------
  661. *-- Programmer..: Jay Parsons (Jparsons).
  662. *-- Date........: 04/26/1992
  663. *-- Notes.......: Makes an empty dBASE .dbf file
  664. *-- Written for.: dBASE IV, 1.1, 1.5
  665. *-- Rev. History: None
  666. *-- Calls       : Tempname()          function in FILES.PRG
  667. *-- Called by...: Any
  668. *-- Usage.......: DO MakeDbf WITH <cFilename>, <cStrufile>, <cArray>
  669. *-- Example.....: DO MakeDbf WITH Customers, cCustfields
  670. *-- Parameters..: cFilename - filename ( without extension ) of the .dbf to be
  671. *--               created.
  672. *--               cStrufile - name ( without extension ) of a STRUC EXTE .dbf
  673. *--               cArray - name of the array holding field information for the
  674. *--               .dbf.  The array must be dimensioned [ F, 5 ] where F is the
  675. *--               number of fields.  Each row must hold data for one field:
  676. *--                     [ F, 1 ]  field name, character
  677. *--                     [ F, 2 ]  field type, character from set "CDFLMN"
  678. *--                     [ F, 3 ]  field length, numeric.  If field type is
  679. *--                                 D, L, or M, will be ignored
  680. *--                     [ F, 4 ]  field decimals, numeric. optional if 0.
  681. *--                     [ F, 5 ]  field is mdx tag, char $ "YN", optional if N
  682. *-------------------------------------------------------------------------------
  683.   parameters cFname, cSname, aAname
  684.   private nX,cF1,cF2,cF3,cF4,cF5,cStrufile,cFtype
  685.   cF1 = aAname + "[nX,1]"
  686.   cF2 = aAname + "[nX,2]"
  687.   cF3 = aAname + "[nX,3]"
  688.   cF4 = aAname + "[nX,4]"
  689.   cF5 = aAname + "[nX,5]"
  690.   select select()
  691.   use ( cSname ) ALIAS cSname
  692.   zap
  693.   nX = 1
  694.   do while type( cF1 ) # "U"
  695.     cFtype = &cF2
  696.     append blank
  697.     replace Field_name with &cF1, Field_type with cFtype
  698.     do case
  699.       case cFtype = "D"
  700.         replace Field_len with 8
  701.       case cFtype = "M"
  702.         replace Field_len with 10
  703.       case cFtype = "L"
  704.         replace Field_len with 1
  705.       otherwise
  706.         replace Field_len with &cF3
  707.     endcase
  708.     if type( cF4 ) = "N" .and. cFtype $ "FN"
  709.         replace Field_dec with &cF4
  710.     else
  711.     replace Field_dec with 0
  712.     endif
  713.     if type( cF5 ) # "U" .and. cFtype $ "CDFN" .and. &cF5 = "Y"
  714.       replace Field_idx with "Y"
  715.     else
  716.       replace Field_idx with "N"
  717.     endif
  718.     nX = nX + 1
  719.   enddo
  720.   use
  721.   create ( cFname ) FROM ( cSname )
  722.  
  723. RETURN
  724. *-- EoP: Makedbf
  725.  
  726. PROCEDURE MakeDBF2
  727. *-------------------------------------------------------------------------------
  728. *-- Programmer..: Bowen Moursund
  729. *-- Date........: 05-27-1992
  730. *-- Notes.......: Creates an empty DBF file of the structure specified in
  731. *--               the array aMakeDBF[], which must be declared and initialized
  732. *--               with the proper values before calling this procedure.
  733. *--               The array must be declared as aMakeDBF[n,5], where n is
  734. *--               the number of fields in the DBF to be created. The columns
  735. *--               of the array correspond to the fields of a structure extended
  736. *--               file, and must be initialized to the appropriate values,
  737. *--               before calling this procedure, one row for each field.
  738. *--
  739. *--               Structure of a structure extended file:
  740. *--               Field    Type  Len  Dec
  741. *--               -----------------------
  742. *--               FIELD_NAME  C   10    0
  743. *--               FIELD_TYPE  C    1    0
  744. *--               FIELD_LEN   N    3    0
  745. *--               FIELD_DEC   N    3    0
  746. *--               FIELD_IDX   C    1    0
  747. *--
  748. *--               aMakeDBF[n,1] = Field name: 10 or less characters
  749. *--               aMakeDBF[n,2] = Field type: 1 character
  750. *--                               "C" = character
  751. *--                               "N" = numeric
  752. *--                               "F" = float
  753. *--                               "D" = date
  754. *--                               "L" = logical
  755. *--                               "M" = memo
  756. *--               aMakeDBF[n,3] = Field length: numeric
  757. *--                               "C" = 1 - 254
  758. *--                               "N","F" = use dBASE guidelines
  759. *--                               "D" = 8
  760. *--                               "L" = 1
  761. *--                               "M" = 10
  762. *--               aMakeDBF[n,4] = Decimal places: numeric
  763. *--                               0 for non numeric fields
  764. *--               aMakeDBF[n,5] = MDX flag: 1 char, "Y" or "N"
  765. *--
  766. *-- Written for.: dBASE IV, 1.5
  767. *-- Rev. History: None
  768. *-- Calls.......: None
  769. *-- Called by...: Any
  770. *-- Usage.......: do MakeDBF with <cDBFpath>,<cStruPath>
  771. *-- Example.....: cStruPath = MakeStru2(.f.)
  772. *--               declare aMakeDBF[1,5]
  773. *--               aMakeDBF[1,1] = "FIELD1"
  774. *--               aMakeDBF[1,2] = "C"
  775. *--               aMakeDBF[1,3] = 20
  776. *--               aMakeDBF[1,4] = 0
  777. *--               aMakeDBF[1,5] = "N"
  778. *--               do MakeDBF2 with "foo", cStruPath
  779. *--               erase (cStruPath+".dbf")
  780. *--               release aMakeDBF
  781. *-- Returns.....: none
  782. *-- Parameters..: cDBFpath = the [path]filename of the DBF to be created.
  783. *--               cStruPath = the [path]filename of an empty structure extended
  784. *--                           file.
  785. *-------------------------------------------------------------------------------
  786.  
  787.    parameters cDBFpath,cStruPath
  788.    if pcount() = 2  && we need 2 parms
  789.       private all except aMakeDB*
  790.       if type("aMakeDBF[1,1]") = "C"  && check array validity
  791.          cAlias = alias()
  792.          select select()
  793.          use (cStruPath)
  794.          append from array aMakeDBF
  795.          use
  796.          create (cDBFpath) from (cStruPath)
  797.          use
  798.          if "" # cAlias
  799.             select (cAlias)
  800.          endif
  801.       endif
  802.    endif
  803.  
  804. RETURN
  805. *-- EoP: MakeDBF2
  806.  
  807. FUNCTION Makestru
  808. *-------------------------------------------------------------------------------
  809. *-- Programmer..: Martin Leon (Hman), formerly sysop of A-T BBS
  810. *--             : Revised by Jay Parsons, (Jparsons).
  811. *-- Date........: 04/24/1992
  812. *-- Notes.......: Makes an empty dBASE STRUCTURE EXTENDED file and returns
  813. *--             : its root name
  814. *-- Written for.: dBASE IV v1.5
  815. *-- Rev. History: 06/12/1991 - original function.
  816. *--             : Changed to take no parameter, return filename, 4-7-1992.
  817. *--             : Code added to preserve catalog status and name, 4-10-1992.
  818. *--             : Use of Tempname() added 4-24-92.
  819. *--             : set("safety") check, minor mods, 05-28-1992, Bowen Moursund
  820. *-- Calls       : Tempname()          Function in FILES.PRG
  821. *-- Called by...: Any
  822. *-- Usage.......: Makestru()
  823. *-- Example.....: Tempfile = Makestru()
  824. *-- Returns.....: Name of file created
  825. *-- Parameters..: None
  826. *-------------------------------------------------------------------------------
  827.  
  828.    private all
  829.    lTitleOn = ( set("TITLE") = "ON" )
  830.    lSafeOn = ( set("SAFETY") = "ON" )
  831.    lCatOff = ( set("CATALOG") = "OFF" )
  832.    cAlias = alias()
  833.    cTmpCat = TempName("cat") + ".CAT"
  834.    set title off
  835.    set safety off
  836.    cCatalog = catalog()
  837.    set catalog to (cTmpCat)
  838.    set catalog to &cCatalog.
  839.    cStruName = TempName("dbf")
  840.    select select()
  841.    use (cTmpCat) nosave
  842.    copy to (cStruName) structure extended
  843.    use (cStruName) exclusive
  844.    zap
  845.    use
  846.    if lTitleOn
  847.       set title on
  848.    endif
  849.    if lSafeOn
  850.       set safety on
  851.    endif
  852.    if lCatOff
  853.       set catalog off
  854.    endif
  855.    if "" # cAlias
  856.       select (cAlias)
  857.    endif
  858.     
  859. RETURN cStruname
  860. *-- Eof: Makestru()
  861.  
  862. FUNCTION MakeStru2
  863. *-------------------------------------------------------------------------------
  864. *-- Programmer..: Bowen Moursund (BOWEN)
  865. *-- Date........: 05-27-1992
  866. *-- Notes.......: Create an empty STRUCTURE EXTENDED file, using DBASE print
  867. *--               redirection. If specified, the file will be created in the
  868. *--               subdirectory pointed to by the DOS environment variable
  869. *--               DBTMP, if it is set, otherwise in the current subdirectory.
  870. *--
  871. *--               Structure of a STRUCTURE EXTENDED file:
  872. *--               Field    Type  Len  Dec
  873. *--               -----------------------
  874. *--               FIELD_NAME  C   10    0
  875. *--               FIELD_TYPE  C    1    0
  876. *--               FIELD_LEN   N    3    0
  877. *--               FIELD_DEC   N    3    0
  878. *--               FIELD_IDX   C    1    0
  879. *--
  880. *-- Written for.: dBASE IV v1.1
  881. *-- Rev. History: None
  882. *-- Calls.......: TEMPNAME
  883. *-- Called by...: Any, except when printing
  884. *-- Usage.......: MakeStru(<lDBTMP>)
  885. *-- Example.....: cStruPath = MakeStru2(.T.)
  886. *-- Returns.....: The name, no extension, of the file created.
  887. *-- Parameters..: lDBTMP = create the file in the DBTMP subdirectory, or not.
  888. *-- Side Effects: WARNING: Do not call when printing.
  889. *-------------------------------------------------------------------------------
  890.  
  891.    parameter lDBTMP
  892.    private all
  893.    cDBTMP = ""  && TempName() will assign this, if lDBTMP
  894.    if lDBTMP
  895.       cFname = TempName( "dbf", .t. )
  896.    else
  897.       cFname = TempName( "dbf", .f. )
  898.    endif
  899.    cPath = iif( "" # cDBTMP, cDBTMP, set("DIRECTORY") ) + "\" + cFname + ".DBF"
  900.    dDate = date()
  901.    set printer to file (cPath)
  902.    set printer on
  903.    * Thanks to JPARSONS for the suggestion to document the header structure
  904.    ??? "{3}"           && various bit flags
  905.    ??? chr(year(dDate)-1900) + chr(month(dDate)) + ;
  906.        chr(day(dDate)) && date bytes in YYMMDD format
  907.    ??? "{0}{0}{0}{0}"  && no. of records
  908.    ??? "{193}{0}"      && no. of bytes in header
  909.    ??? "{19}{0}"       && no. of bytes per record
  910.    ??? "{0}{0}"        && reserved
  911.    ??? "{0}"           && incomplete transaction flag
  912.    ??? "{0}"           && encryption flag
  913.    ??? "{0}{0}{0}{0}{0}{0}{0}{0}{0}" + ;
  914.        "{0}{0}{0}"     && multi-user reserved
  915.    ??? "{0}"           && MDX flag
  916.    ??? "{0}{0}{0}"     && reserved
  917.    * field descriptors
  918.    ??? "{70}{73}{69}{76}{68}{95}{78}{65}{77}{69}{0}{67}{3}{0}{208}" + ;
  919.        "{72}{10}{0}{0}{0}{1}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}"  && Field_Name
  920.    ??? "{70}{73}{69}{76}{68}{95}{84}{89}{80}{69}{0}{67}{13}{0}{208}" + ;
  921.        "{72}{1}{0}{0}{0}{1}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}"   && Field_Type
  922.    ??? "{70}{73}{69}{76}{68}{95}{76}{69}{78}{0}{0}{78}{14}{0}{208}" + ;
  923.        "{72}{3}{0}{0}{0}{1}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}"   && Field_Len
  924.    ??? "{70}{73}{69}{76}{68}{95}{68}{69}{67}{0}{0}{78}{17}{0}{208}" + ;
  925.        "{72}{3}{0}{0}{0}{1}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}"   && Field_Dec
  926.    ??? "{70}{73}{69}{76}{68}{95}{73}{68}{88}{0}{0}{67}{20}{0}{208}" + ;
  927.        "{72}{1}{0}{0}{0}{1}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}"   && Field_Idx
  928.    ??? "{13}{26}"
  929.    set printer to
  930.    set printer off
  931.  
  932. RETURN cFname
  933. *-- Eof() MakeStru2
  934.  
  935. FUNCTION TempName
  936. *-------------------------------------------------------------------------------
  937. *-- Programmer..: Martin Leon (HMAN)  Former Sysop, ATBBS
  938. *-- Date........: 05-27-1992
  939. *-- Notes.......: Obtain a name for a temporary file of a given extension
  940. *--               that does not conflict with existing files.
  941. *-- Written for.: dBASE IV, v1.5
  942. *-- Rev. History: Originally part of Makestru(), 6-12-1991
  943. *--               04/26/92, made a separate function - Jay Parsons
  944. *--               05/27/92, added lDBTMP option - Bowen Moursund
  945. *-- Calls.......: None
  946. *-- Called by...: Any
  947. *-- Usage.......: TempName( cExt , lDBTMP )
  948. *-- Example.....: Sortfile = TempName( "DBF" , .t. )
  949. *-- Returns.....: Name not already in use. Additionally, if the memvar
  950. *--               cDBTMP is declared before calling the function with
  951. *--               the lDBTMP option, it will be assigned the result
  952. *--               of getenv("DBTMP").
  953. *-- Parameters..: cExt   = Extension to be given file ( without the "." )
  954. *--               lDBTMP = Optional. If .t., function returns unique file
  955. *--                        name in the DBTMP subdirectory.
  956. *-- Side Effects: The function will return a unique filename for the DEFAULT
  957. *--               subdirectory if the lDBTMP option is used and the DOS
  958. *--               environment variable DBTMP does not point to a valid
  959. *--               subdirectory.
  960. *-------------------------------------------------------------------------------
  961.  
  962.    parameters cExt, lDBTMP
  963.    private all except cDBTMP
  964.    cDefDir = set("DIRECTORY")
  965.    if lDBTMP
  966.       cDBTMP = getenv("DBTMP")
  967.       if "" # cDBTMP
  968.          set directory to &cDBTMP.
  969.       endif
  970.    endif
  971.    do while .t.
  972.       Fname = "TMP" + ltrim( str( rand() * 100000, 5 ) )
  973.       if .not. file( Fname + "." + cExt ) .and. ( upper( cExt ) # "DBF" .or.;
  974.          .not. ( file( Fname + ".MDX" ) .or. file ( Fname + ".DBT" ) ) )
  975.             exit
  976.       endif
  977.    enddo
  978.    set directory to &cDefDir.
  979.  
  980. RETURN Fname
  981. *-- Eof() TempName
  982.  
  983. PROCEDURE FileMove
  984. *-------------------------------------------------------------------------------
  985. *-- Programmer..: David Frankenbach (FRNKNBCH)
  986. *--               DF Software Development, Inc.
  987. *--               PO Box 87
  988. *--               Forest, VA, 24551
  989. *--               (804) 237-2342
  990. *-- Date........: 02/11/1992
  991. *-- Notes.......: This procedure gives the record movement allowed with EDIT
  992. *--               when you use a simple @SAY/GET..READ. It allows you to
  993. *--               pre/post process each record during editing, something you
  994. *--               can't do with EDIT. This works best with a single file,
  995. *--               although it would work with a parent->child relation. You
  996. *--               should:  SELECT child and SET SKIP to child. This will
  997. *--               allow the user to change the parent record pointer though!
  998. *--               If you want to limit the child record movement to a single
  999. *--               parent record, you can use a conditional index, or add logic
  1000. *--               to the routine to limit the record pointer movement. For these
  1001. *--               cases I have a seperate FileMove procedure, but they are not
  1002. *--               generic enough for public consumption.
  1003. *--
  1004. *--               These keys are trapped:
  1005. *--               UpArw, Shift-Tab, LeftArw, Ctrl-LeftArw, PgUp = 
  1006. *--                                                         backward one record
  1007. *--               DnArw, Tab, RightArw, Ctrl-RightArw, PgDn, Enter, Ctrl-End = 
  1008. *--                                                         forward one record
  1009. *--               Ctrl-PgUp = top of database or active index
  1010. *--               Ctrl-PgDn = bottom of database or active index
  1011. *-- Written for.: dBASE IV, 1.1
  1012. *-- Rev. History: 06/17/1991 - original routine.
  1013. *--               02/07/1992 -- Ken Mayer, brought into one PROCEDURE,
  1014. *--               rather than a function and a procedure ...
  1015. *--               02/11/1992 -- Author, additional documentation
  1016. *--                             Released into Public Domain
  1017. *-- Calls.......: None
  1018. *-- Called by...: None
  1019. *-- Usage.......: do FileMove with <nKey>
  1020. *--               where: <nKey> is the return value of readkey()
  1021. *-- Example.....: lMove = .t.  && if you want the user to be able to move the 
  1022. *--                            && record pointer in my applications if the user
  1023. *--                            && is adding a new record I usually lMove = .f.,
  1024. *--                            && for editing I allow them to move through the
  1025. *--                            && records.
  1026. *--               lOk = .t.
  1027. *--               do while ( lOk )
  1028. *--                  do Mem_Load               && load memvars from record
  1029. *--                  @say/gets                 && display/get the memvars
  1030. *--                  read
  1031. *--                  i = readkey()             && grab last key ...
  1032. *--                  lOk = ( i <> 27 )         && if Esc was pressed lOK is false
  1033. *--                  if ( lOk )
  1034. *--                     if ( i > 256 )         && if record is changed
  1035. *--                        do Mem_Unload       && replace dbf fields from memvars
  1036. *--                     endif  && ( i > 256 )
  1037. *--                     if ( lMove )           && if ok to move record pointer
  1038. *--                        do FileMove with i  && <----- Move it
  1039. *--                     else
  1040. *--                        lOk = .f.            && terminate loop if .not. lMove
  1041. *--                     endif  && ( lMove )
  1042. *--                  endif && (lOK)
  1043. *--               enddo && while (lOK)
  1044. *-- Parameters..: nKey = last keystroke from a READKEY() call ...
  1045. *-- Returns.....: None
  1046. *-- Side Effects: Moves record pointer in current file if lMove = .t.
  1047. *-------------------------------------------------------------------------------
  1048.     parameter nKey
  1049.     private n
  1050.     
  1051.     m->n = m->nKey
  1052.     if ( m->n > 255 )     && if value is > 256, record has changed, but we want
  1053.        m->n = m->n - 256  && values < 256 to figure out which direction to move
  1054.     endif                 && from the readkey() table
  1055.     
  1056.     do case
  1057.     
  1058.        *-- keys to move backward through database 1 record at a time ...
  1059.        *--  LeftArw, Ctrl-LeftArw, UpArw, Shift-Tab, PgUp
  1060.        case ( m->n = 0 ) .or. ( m->n = 2 ) .or. ( m->n = 4 ) .or. ( m->n = 6 )
  1061.           if ( .not. bof() )                && if not at beginning of file
  1062.              skip -1                        && move backward one record
  1063.           endif
  1064.     
  1065.        *-- keys to move forward through database 1 record at a time ...
  1066.        *--  RightArw, Ctrl-RightArw, DownArw, Tab, PgDn, Ctrl-End, Enter
  1067.        case ( m->n = 1 ) .or. ( m->n = 3 ) .or. ( m->n = 5 ) .or. ( m->n = 7 );
  1068.              .or. ( m->n = 14) .or. ( m->n = 15)
  1069.           if ( .not. eof() )                && if not end of file
  1070.              skip 1                         && move forward one record
  1071.           endif
  1072.           if ( eof() )                      && if we're now at the EOF,
  1073.              goto bottom                    && go back to last record ...
  1074.           endif
  1075.     
  1076.        *-- go to toP of database, Ctrl-PgUp
  1077.        case ( m->n = 34 )
  1078.           goto top
  1079.     
  1080.        *-- go to BOTtoM of database, Ctrl-PgDn
  1081.        case ( m->n = 35 )
  1082.           goto bottom
  1083.     
  1084.     endcase
  1085.  
  1086. RETURN
  1087. *-- EoP: FileMove
  1088.  
  1089. FUNCTION Used
  1090. *-------------------------------------------------------------------------------
  1091. *-- Programmer..: Ken Mayer (KENMAYER)
  1092. *-- Date........: 05/15/1992
  1093. *-- Notes.......: Created because the picklist routine by Malcolm Rubel
  1094. *--               from DBA Magazine (11/91) calls a function that checks
  1095. *--               to see if a DBF file is open ... the one he calls doesn't
  1096. *--               exist. This is designed to loop until all possible work
  1097. *--               areas are checked (for 1.1 this maxes at 10, for 1.5 it's
  1098. *--               40 ... this routine checks both). Written for PICK2,
  1099. *--               this should be transportable ...
  1100. *-- Written for.: dBASE IV, 1.5
  1101. *-- Rev. History: None
  1102. *-- Calls.......: None
  1103. *-- Usage.......: Used("<cFile>")
  1104. *-- Example.....: if used("Library")
  1105. *--                  select library
  1106. *--               else
  1107. *--                  select select()
  1108. *--                  use library
  1109. *--               endif
  1110. *-- Returns.....: Logical (.t. if file is in use, .f. if not)
  1111. *-- Parameters..: cFile = file to check for
  1112. *-------------------------------------------------------------------------------
  1113.     
  1114.     parameters cFile
  1115.     private lReturn, nAlias, nMax
  1116.  
  1117.     *-- maximum # of work areas is based on version of dBASE ...
  1118.     *-- if 1.5 or higher, the max is 40, if 1.1 or lower, it's 10.
  1119.     if val(right(version(),3)) > 1.1
  1120.         nMax = 40
  1121.     else
  1122.         nMax = 10
  1123.     endif
  1124.     
  1125.     *-- a small loop
  1126.     nAlias = 0                          && start at 0, increment as we go
  1127.     lReturn = .f.                       && assume it's not open
  1128.     do while nAlias < nMax              && loop until we find it, or we max
  1129.         nAlias = nAlias + 1              && increment
  1130.         if alias(nAlias) = upper(cFile)  && is THIS the one?
  1131.             lReturn = .t.                 && if so, set lReturn to .t.
  1132.             exit                          &&   and exit the loop
  1133.         endif  && if alias ...
  1134.     enddo
  1135.     
  1136. RETURN lReturn
  1137. *-- EoF: Used
  1138.  
  1139. FUNCTION MDXbyte
  1140. *-------------------------------------------------------------------------------
  1141. *-- Programmer..: Bowen Moursund
  1142. *-- Date........: 05-21-1992
  1143. *-- Notes.......: Sets the MDX byte in a DBF header ON or OFF.
  1144. *--               The DBF must not be open when the function is called.
  1145. *-- Written for.: dBASE IV v1.5
  1146. *-- Rev. History: None
  1147. *-- Calls.......: dBASE low level file functions
  1148. *-- Called by...: Any
  1149. *-- Usage.......: MDXbyte(<cDBFpath>,<cOnOff>)
  1150. *-- Example.....: lByteSet = MDXbyte("mydbf.dbf","OFF")
  1151. *-- Returns.....: .T. if successful
  1152. *-- Parameters..: cDBFpath = the [path]filename.ext of the DBF
  1153. *--               cOnOff   = "ON" or "OFF"
  1154. *-------------------------------------------------------------------------------
  1155.  
  1156.    parameters cDBFpath,cOnOff
  1157.    private all
  1158.    cOnOff = upper(cOnOff)
  1159.    * check the validity of the parameters
  1160.    lSuccess = ( pcount() = 2 .AND. cOnOff $ "ON|OFF" .AND. file(cDBFpath) )
  1161.    if lSuccess
  1162.       nHandle = fopen(cDBFpath,"RW")
  1163.       if nHandle > 0
  1164.          if fseek(nHandle, 28) = 28
  1165.             lSuccess = ( fwrite(nHandle, iif(cOnOff="OFF",chr(0),chr(1))) = 1 )
  1166.          else
  1167.             lSuccess = .F.
  1168.          endif
  1169.          lClosed = fclose(nHandle)
  1170.       else
  1171.          lSuccess = .F.
  1172.       endif
  1173.    endif
  1174.  
  1175. RETURN lSuccess
  1176. *-- Eof() MDXbyte
  1177.  
  1178. FUNCTION aDir
  1179. *-------------------------------------------------------------------------------
  1180. *-- Programmer..: Bowen Moursund
  1181. *-- Date........: 07-24-1992
  1182. *-- Notes.......: aDir() creates a public array gaDir[ n, 5 ] containing
  1183. *--               directory information. gaDir[ n, 5 ] is limited to 234
  1184. *--               rows (files) or less, depending on the memory available.
  1185. *--
  1186. *--                     Structure of 2D array gaDir[ n, 5 ]:
  1187. *--
  1188. *--                     Col  Contents             Type       Width
  1189. *--                     ------------------------------------------
  1190. *--                       1  File Name            Character     12
  1191. *--                       2  Date (mm/dd/yy)      Date           8
  1192. *--                       3  Time (hh:mm:ss)      Character      8
  1193. *--                       4  Size (bytes)         Numeric       10
  1194. *--                       5  Attributes           Character      6
  1195. *--
  1196. *--               aDir() makes use of Search.Bin, and credit is due its
  1197. *--               author. See ASM source for details.
  1198. *--               *****************************
  1199. *--               **** REQUIRES SEARCH.BIN ****
  1200. *--               *****************************
  1201. *-- Written for.: dBASE IV, v1.5
  1202. *-- Rev. History: None
  1203. *-- Calls.......: None
  1204. *-- Called by...: Any
  1205. *-- Usage.......: adir( <cFMask>, <cBINpath>, <cAttr> )
  1206. *-- Examples....: nFiles = adir( "d:\app\fu*.db?", "d:\dbase4\library\", "" )
  1207. *--               nFiles = adir( cPathSkel )
  1208. *--               nFiles = adir( "c:\*.*", "", "RHSD" )
  1209. *-- Returns.....: Number of matching files found: rows in gaDir[]
  1210. *-- Parameters..: cPathSkel = the directory path and file skeleton that you
  1211. *--                           want, like the DOS DIR command. Wildcards OK.
  1212. *--               cBINpath = Optional path to Search.Bin. If omitted,
  1213. *--                          Search.Bin must be in current subdirectory.
  1214. *--                          Include the trailing backslash.
  1215. *--               cAttr = Optional file attribute mask string.
  1216. *--
  1217. *--                             Mask Codes
  1218. *--                            ------------
  1219. *--                            R - Read Only
  1220. *--                            H - Hidden
  1221. *--                            S - System
  1222. *--                            D - Directory
  1223. *--                            V - Volume
  1224. *--                            A - Archive
  1225. *--
  1226. *--                       If cAttr is omitted, null, or blank, gaDir[] will
  1227. *--                       contain only 'ordinary' files, i.e. files without
  1228. *--                       HSDV attributes. If V is specified in the mask,
  1229. *--                       ONLY volume labels are matched. Any other attribute
  1230. *--                       or combination of attributes results in those files
  1231. *--                       AND ordinary files being matched.
  1232. *-------------------------------------------------------------------------------
  1233.  
  1234.     parameters cPathSkel, cBINpath, cAttr
  1235.     private all except gaDir
  1236.     cModule = iif( pcount() >= 2, cBINpath + "search.bin", "search.bin" )
  1237.     store upper( iif( pcount() >= 3, left( cAttr + "      ", 6 ), "      " ) ) ;
  1238.                  to cAttr, cFAttr
  1239.     cFSkel = left( cPathSkel + space(12), max( len( cPathSkel ), 12 ) )
  1240.     cFName = cFSkel
  1241.     * ( memory() * 3.4 ) is a guess on max rows before 'Insufficient Memory'
  1242.     nMaxRows = min( memory() * 3.4, 234 )  && 234 is the absolute maximum
  1243.     nFCount = 0
  1244.     load ( cModule )
  1245.     nResult = call( "Search", 1, cFName, cAttr )
  1246.     if nResult = 0
  1247.         do while nResult = 0 .and. nFCount <= nMaxRows
  1248.             nFCount = nFCount + 1
  1249.             nResult = call( "Search" , 2, cFName )
  1250.         enddo
  1251.         nFCount = min( nMaxRows, nFCount )
  1252.         release gaDir
  1253.         public array gaDir[ nFCount, 5 ]
  1254.         cFName = cFSkel
  1255.         cFDate = "  /  /  "
  1256.         cFTime = "  :  :  "
  1257.         nFSize = 0
  1258.         n = 1
  1259.         nResult = ;
  1260.         call( "Search", 1, cFName, cFAttr, cFDate, cFTime, nFSize )
  1261.         do while nResult = 0 .AND. n <= nFCount
  1262.             store cFName to         gaDir[ n, 1 ]
  1263.             store ctod( cFDate ) to gaDir[ n, 2 ]
  1264.             store cFTime to         gaDir[ n, 3 ]
  1265.             store nFSize to         gaDir[ n, 4 ]
  1266.             store cFAttr to         gaDir[ n, 5 ]
  1267.             nResult = ;
  1268.              call( "Search", 2, cFName, cFAttr, cFDate, cFTime, nFSize )
  1269.             n = n + 1
  1270.         enddo
  1271.     else
  1272.         release gaDir
  1273.     endif
  1274.     release module Search
  1275.  
  1276. RETURN nFCount
  1277. *-- EoF: aDir()
  1278.  
  1279. FUNCTION DbfDir
  1280. *-------------------------------------------------------------------------------
  1281. *-- Programmer..: Bowen Moursund
  1282. *-- Date........: 07-03-1992
  1283. *-- Notes.......: DbfDir() creates or OVERWRITES DdbDir.Dbf, and populates
  1284. *--               it with directory information. The function uses the DOS
  1285. *--               5.0 DIR command and requires DOS 5.0.
  1286. *--
  1287. *--                          Structure of DBFDIR.DBF
  1288. *--                          -----------------------
  1289. *--                          Field    Type  Len  Dec
  1290. *--                          F_NAME      C   12    0
  1291. *--                          F_DATE      D    8    0
  1292. *--                          F_TIME      C    8    0
  1293. *--                          F_SIZE      N   10    0
  1294. *--               *********************************************************
  1295. *--               * DO NOT CALL THIS ROUTINE WHILE PRINTING (the function *
  1296. *--               * uses Print Redirection ...)                           *
  1297. *--               *********************************************************
  1298. *-- Written for.: dBASE IV v1.5, DOS 5.0
  1299. *-- Rev. History: None
  1300. *-- Calls.......: TempName()           Function in FILES.PRG
  1301. *-- Called by...: None
  1302. *-- Usage.......: DbfDir( "<cPathSkel>", <lHidSys> )
  1303. *-- Examples....: nFiles = DbfDir( "*.dbf" )
  1304. *--               nFiles = DbfDir( "*.dbf", .t. )
  1305. *-- Returns.....: Number of matching files found: reccount() of DbfDir.dbf
  1306. *-- Parameters..: cPathSkel = the directory path and file skeleton that you
  1307. *--                           want, like the DOS DIR command. Wildcards OK.
  1308. *--               lHidSys   = Optional. If .t., hidden & system files
  1309. *--                           are included.
  1310. *-------------------------------------------------------------------------------
  1311.  
  1312.     parameters cPathSkel, lHidSys
  1313.     private all
  1314.     cDBTMP = ""
  1315.     cTmpFile = tempname( "txt", .t. ) + ".txt"
  1316.     cTmpFile = iif( "" = cDBTMP, cTmpFile, cDBTMP + "\" + cTmpFile )
  1317.     cDirParms = iif( lHidSys, "/B/A-D/ON", "/B/A-D-H-S/ON" )
  1318.     run dir &cPathSkel. &cDirParms. > &cTmpFile.
  1319.     nFiles = 0
  1320.     if fsize( cTmpFile ) > 0
  1321.         lSafeOn = ( set( "safety" ) = "ON" )
  1322.         set safety off
  1323.         set printer to file DbfDir.dbf  && create DbfDir.dbf
  1324.         set printer on
  1325.         * first byte of header - various bit flags
  1326.         ??? "{3}"
  1327.         * next 3 bytes - file date in binary YYMMDD
  1328.         ??? chr(year(date())-1900) + chr(month(date())) + chr(day(date()))
  1329.         * the rest of the header, field descriptors, and records if any
  1330.         ??? "{0}{0}{0}{0}{161}{0}{39}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}"+;
  1331.         "{0}{0}{0}{0}{0}{0}{0}{1}{1}{70}{95}{78}{65}{77}{69}{0}{0}{0}{0}{0}"+;
  1332.         "{67}{0}{0}{0}{0}{12}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}"+;
  1333.         "{70}{95}{68}{65}{84}{69}{0}{0}{0}{0}{0}{68}{0}{0}{0}{0}"
  1334.         ??? "{8}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{70}{95}{84}"+;
  1335.         "{73}{77}{69}{0}{0}{0}{0}{0}{67}{0}{0}{0}{0}{8}{0}{0}{0}{0}{0}{0}"+;
  1336.         "{0}{0}{0}{0}{0}{0}{0}{0}{0}{70}{95}{83}{73}{90}{69}{0}{0}{0}{0}{0}"+;
  1337.         "{78}{0}{0}{0}{0}{10}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}"
  1338.         ??? "{0}{0}{0}{13}{26}"
  1339.         set printer to
  1340.         set printer off
  1341.         cAlias = alias()
  1342.         select select()
  1343.         use DbfDir
  1344.         append from ( cTmpFile ) sdf
  1345.         goto top
  1346.         cPath = parspath( cPathSkel )
  1347.         scan
  1348.             replace f_size with fsize( cPath + f_name ),;
  1349.                     f_date with fdate( cPath + f_name ),;
  1350.                     f_time with ftime( cPath + f_name )
  1351.         endscan
  1352.         nFiles = reccount()
  1353.         use
  1354.         if lSafeOn
  1355.             set safety on
  1356.         endif
  1357.         if "" # cAlias
  1358.             select ( cAlias )
  1359.         endif
  1360.     endif
  1361.     erase ( cTmpFile )
  1362.  
  1363. RETURN nFiles
  1364. *-- EoF: DBFDir()
  1365.  
  1366. FUNCTION ParsPath
  1367. *-------------------------------------------------------------------------------
  1368. *-- Programmer..: Bowen Moursund
  1369. *-- Date........: 07-16-1992
  1370. *-- Notes.......: ParsPath() extracts and returns the path from a
  1371. *--               full path file specification.
  1372. *-- Written for.: dBASE IV v1.1
  1373. *-- Rev. History: None
  1374. *-- Calls.......: None
  1375. *-- Called by...: Any
  1376. *-- Usage.......: ParsePath( "<cFullPath>" )
  1377. *-- Example.....: set fullpath on
  1378. *--               cDBF = dbf()
  1379. *--               cPath = ParsPath( cDBF )
  1380. *-- Returns.....: The path only, including the trailing backslash,
  1381. *--               of the full path file specification
  1382. *-- Parameters..: cFullPath = a full path file spec, e.g. "c:\dbase\dbase.exe"
  1383. *-------------------------------------------------------------------------------
  1384.  
  1385.     parameter cFullPath
  1386.     private all
  1387.     cPath = ""
  1388.     if "\" $ cFullPath
  1389.         nPos = 1
  1390.         do while left( right ( cFullPath, nPos ), 1 ) # "\"
  1391.             nPos = nPos + 1
  1392.         enddo
  1393.         cPath = substr( cFullPath, 1, len( cFullPath ) - nPos + 1)
  1394.     endif
  1395.  
  1396. RETURN cPath
  1397. *-- EoF: ParsPath()
  1398.  
  1399. *-------------------------------------------------------------------------------
  1400. *-- EoP: FILES.PRG
  1401. *-------------------------------------------------------------------------------
  1402.