home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / xbase / library / dbase / duflp / obsolete.prg < prev    next >
Text File  |  1992-07-24  |  16KB  |  381 lines
  1. *-------------------------------------------------------------------------------
  2. *-- Program...: OBSOLETE.PRG
  3. *-- Programmer: Ken Mayer (KENMAYER)
  4. *-- Date......: 04/30/1992
  5. *-- Notes.....: The following functions are not necessary using dBASE IV, 1.5,
  6. *--             but have been retained in the current version of the library
  7. *--             system in order to have some compatibility with 1.1.
  8. *-------------------------------------------------------------------------------
  9.  
  10. FUNCTION Empty
  11. *-------------------------------------------------------------------------------
  12. *-- Programmer..: Jerry Wightman (WIGHTMAN)
  13. *-- Date........: ?
  14. *-- Notes.......: Used to check whether a memory variable in dBASE contains
  15. *--               anything, based on type of field. (Pulled from BORBBS)
  16. *--               NOTE: In release 1.5, replace all calls to EMPTY() with
  17. *--               the new:  ISBLANK() function. This will be faster.
  18. *-- Written for.: dBASE IV, 1.1
  19. *-- Rev. History: None
  20. *-- Calls.......: None
  21. *-- Called by...: Any
  22. *-- Usage.......: Empty(<cFld>)
  23. *-- Example.....: @5,10 say "Enter date: " get bDate;
  24. *--                         valid required .not. empty(bDate);
  25. *--                         error chr(7)+"** Date cannot be Empty! **"
  26. *-- Returns.....: Logical (.t./.f.)
  27. *-- Parameters..: cFld  =  Field/Memvar/Expression to check for "Emptiness"
  28. *-------------------------------------------------------------------------------
  29.  
  30.     PARAMETERS cFld       && may be memory variable or database field name
  31.     private cTalk, lReturn
  32.  
  33.     cTalk = SET("TALK")
  34.  
  35.     lReturn = .F.      &&  FALSE means:  variable is NOT empty
  36.  
  37.     do case
  38.        case type( "cFld" ) = "C"
  39.           if len( ltrim(rtrim( cFld )) ) = 0
  40.              lReturn = .T.
  41.             endif
  42.  
  43.         case type( "cFld" ) = "N" .or. type( "cFld" ) = "F"
  44.             if cFld = 0
  45.                 lReturn = .T.
  46.             endif
  47.  
  48.         case type( "cFld" ) = "L"
  49.             lReturn = .F.  && Can't check logical fields
  50.  
  51.         case type( "cFld" ) = "D"
  52.             if cFld = {}
  53.                 lReturn = .T.
  54.             endif
  55.  
  56.         case type( "cFld" ) = "M"
  57.             if len( cFld ) = 0
  58.                                 lReturn = .T.
  59.             endif
  60.  
  61.         otherwise   && TYPE = "U"
  62.             lReturn = .T.
  63.  
  64.     endcase
  65.  
  66.     set talk &cTalk
  67.     
  68. RETURN lReturn
  69. *-- EoF: Empty()
  70.  
  71. FUNCTION NumFlds
  72. *-------------------------------------------------------------------------------
  73. *-- Programmer..: Bowen Moursund (BOWEN)
  74. *-- Date........: 07/12/1991
  75. *-- Notes.......: Returns the number of fields in a database structure --
  76. *--               only in the currently selected DBF
  77. *--               NOTE: In release 1.5, replace function NUMFLDS() with
  78. *--               FLDCOUNT() -- built in to 1.5, faster ...
  79. *-- Written for.: dBASE IV, 1.1
  80. *-- Rev. History: None
  81. *-- Calls.......: None
  82. *-- Called by...: Any
  83. *-- Usage.......: NumFlds()
  84. *-- Example.....: ? NumFlds()
  85. *-- Returns.....: Number of fields
  86. *-- Parameters..: None
  87. *-------------------------------------------------------------------------------
  88.  
  89.     private nFlds,cFldName
  90.     
  91.     *-- If currently selected database is empty (no dbf file)
  92.     if len(trim(dbf())) = 0
  93.         nFlds = 0                     && set to 0
  94.     *-- we have something ...
  95.     else
  96.         nFlds = 0                     && initialize
  97.         do while .t.                  && loop through the record structure
  98.             nFlds= nFlds + 1           && increment counter
  99.             cFldName = field(nFlds)    && get fieldname
  100.             if len(trim(cFldName)) = 0 && if length = 0,
  101.                 nFlds = nFlds - 1       &&   decrement counter
  102.                 exit                    &&   get out of loop, we're done
  103.             endif                      && endif(length...)
  104.         enddo                         && end of loop
  105.     endif
  106.  
  107. RETURN nFlds
  108. *-- EoF: NumFlds()
  109.  
  110. FUNCTION DateSet
  111. *-------------------------------------------------------------------------------
  112. *-- Programmer..: Jay Parsons (JPARSONS)
  113. *-- Date........: 03/01/1992
  114. *-- Notes.......: Returns string giving name of current DATE format
  115. *--               This is not needed in Version 1.5, in which set("DATE")
  116. *--               returns the format.  Unlike that function in 1.5, this
  117. *--               one cannot distinguish between date formats set with
  118. *--               different terms that amount to the same thing:
  119. *--                     DMY = BRITISH = FRENCH
  120. *--                     MDY = AMERICAN
  121. *--                     YMD = JAPAN
  122. *--               If your users will be using one of these formats and
  123. *--               are sensitive about the name, substitute the one they
  124. *--               want for the equivalent in this function.
  125. *-- Rev. History: None
  126. *-- Written for.: dBASE IV, versions below 1.5
  127. *-- Rev. History: None
  128. *-- Calls.......: None
  129. *-- Called by...: Any
  130. *-- Usage.......: DateSet()
  131. *-- Example.....: ?DateSet()
  132. *-- Returns.....: Character
  133. *-- Parameters..: None
  134. *-------------------------------------------------------------------------------
  135.  
  136.     private cCent, cTestdate, cDelimiter
  137.     cCent = set( "CENTURY" )
  138.     set century off
  139.     cTestdate = ctod( "01/02/03" )
  140.     cDelimiter = substr( dtoc( cTestdate ), 3, 1 )
  141.     set century &cCent
  142.     do case
  143.       case month( cTestdate ) = 1
  144.         RETURN iif( cDelimiter = "-", "USA", "MDY" )
  145.       case day( cTestdate ) = 1
  146.         RETURN iif( cDelimiter = "/", "DMY", ;
  147.           iif( cDelimiter = ".", "GERMAN", "ITALIAN" ) )
  148.       otherwise
  149.         RETURN iif( cDelimiter = ".", "ANSI", "YMD" )
  150.     endcase
  151.     
  152. *-- EoF: DateSet()
  153.  
  154. FUNCTION Stampval
  155. *-------------------------------------------------------------------------------
  156. *-- Programmer..: Jay Parsons (Jparsons)
  157. *-- Date........: 04/07/1992
  158. *-- Notes.......: Passed a 16-character string in the form of the rightmost
  159. *--             : 16 characters returned by the DOS DIR command for a file,
  160. *--             : returns a number that will compare properly in date/time
  161. *--             : order with the numbers returned by this function for other
  162. *--             : files.
  163. *-- Written for.: dBASE IV Versions below 1.5
  164. *-- Rev. History: None
  165. *-- Calls       : None
  166. *-- Called by...: Any
  167. *-- Usage.......: Stampval(<cTimestamp>)
  168. *-- Example.....: IF Stampval("02-22-92  10:54a") > Stampval("04-05-92   5:54p")
  169. *-- Returns.....: Numeric corresponding to time stamp of file
  170. *-- Parameters..: cStamp, a DIR timestamp
  171. *-------------------------------------------------------------------------------
  172.    parameters cStamp
  173.    RETURN 1440 * ( 12 * val( left(cStamp,2)) + val(substr(cStamp,4,2)) ;
  174.        + 372*val(substr(cStamp,7,2)) ) + 60 * val(substr(cStamp,11,2)) ;
  175.        + val(substr(Cstamp,14,2)) + iif(right(cStamp,1)="p",720,0)
  176. *--Eof() Stampval
  177.  
  178. PROCEDURE FullWin
  179. *-------------------------------------------------------------------------------
  180. *-- Programmer..: Ken Mayer (KENMAYER)
  181. *-- Date........: 05/23/91
  182. *-- Notes.......: Overlays menus or another screen with a full window,
  183. *--               so that processing is done in the window, and one can return
  184. *--               directly to the menus, without redrawing screen and such.
  185. *--               This routine may be a problem in dBASE IV, 1.5 ... use
  186. *--               with caution ...
  187. *-- Written for.: dBASE IV, 1.1
  188. *-- Rev. History: None
  189. *-- Calls.......: None
  190. *-- Called by...: Any
  191. *-- Usage.......: do fullwin with <cColor>,<cWinName>,<cScreen>
  192. *-- Example.....: do fullwin with "w+/b","w_Edit","sc_Main"
  193. *--                * perform whatever actions are needed in the window
  194. *--               deactivate window wEdit
  195. *--               release window wEdit
  196. *--               restore screen from sMain
  197. *--               release screen sMain
  198. *-- Returns.....: None
  199. *-- Parameters..: cColor   = Colors for window
  200. *--               cWinName = Name of window
  201. *--               cScreen  = Name of screen
  202. *-------------------------------------------------------------------------------
  203.     
  204.     parameters cColor,cWinName,sScreen
  205.     
  206.     define window &cWinName from 0,0 to 23,79 none color &cColor.
  207.     save screen to &sScreen.
  208.     activate window &cWinName.
  209.     
  210. RETURN  
  211. *-- EoP: FullWin
  212.     
  213. PROCEDURE SetColor
  214. *-------------------------------------------------------------------------------
  215. *-- Programmer..: Phil Steele
  216. *-- Date........: 05/23/91
  217. *-- Notes.......: Used to set the screen colors for a system. It
  218. *--               checks to see if a color monitor is attached (ISCOLOR()),
  219. *--               and sets system variables, that can be used in SET COLOR OF
  220. *--               commands. You must define the memvars as PUBLIC, see Example
  221. *--               below -- otherwise nothing will work.
  222. *-- Written for.: dBASE IV, 1.1
  223. *-- Rev. History: Borrowed from Phil Steele's PCSDEMO (a public domain
  224. *--               program) and commented a bit more, minor modifications by
  225. *--               Ken Mayer (KENMAYER).
  226. *-- Calls.......: None
  227. *-- Called by...: Any
  228. *-- Usage.......: do setcolor
  229. *-- Example.....: in a menu or setup program:
  230. *--               PUBLIC cl_blank,cl_func,cl_help,cl_data,cl_error,;
  231. *--                      cl_entry,cl_stand,cl_menu,cl_warn 
  232. *--               DO setcolor
  233. *--                  by declaring the variables PUBLIC before calling SETCOLOR
  234. *--                  they should be globally available throughout, unless you
  235. *--                  use a CLEAR ALL or RELEASE ALL command ...
  236. *-- Returns.....: None
  237. *-- Parameters..: None
  238. *-------------------------------------------------------------------------------
  239.     
  240.     if file("COLOR.MEM")
  241.         restore from Color.mem additive    && if color.mem exists, restore from it
  242.     else                                && otherwise, create it
  243.         lC           = iscolor()             && remember -- foreground/background
  244.         cl_Blank = "n/n,n/n,n"           && black on black on black ...
  245.         cl_Func  = "n/w"                 && function keys (used in CLRSHOW)
  246.             * if iscolor() = true, define color, otherwise black/white
  247.         cl_Help  = iif(lC,"n/g,g/n,n"      , "w+/n,n/w,n")   && help
  248.         cl_Data  = iif(lC,"rg+/gb,gb/rg,n" , "n/w,w+/n,n")   && data entry fields
  249.         cl_Error = iif(lC,"rg+/r,w/n,n"    , "w+/n,n/w,n")   && error messages
  250.         cl_Entry = iif(lC,"n/w,w/n,n"      , "n/w,w/n,n")    && data entry??
  251.         cl_Stand = iif(lC,"w+/b,b/w,n"     , "w+/n,n/w,n")   && standard screen
  252.         cl_Menu  = iif(lC,"rg+/b,b/w,n"    , "w+/n,n/w,n")   && menus
  253.         cl_Warn  = iif(lC,"rg+/r,w/n,n"    , "w/n,n/w,n")    && warning messages
  254.         save to color all like cl_*        && create COLOR.MEM
  255.     endif
  256.     
  257.     *-- change current color settings to these ...
  258.     set color to &cl_stand                         
  259.     cTemp = extrclr("&cl_data")  
  260.     set color of fields   to &cTemp
  261.     set color of messages to &cTemp
  262.     set color of box      to &cTemp
  263.     cTemp = extrclr("&cl_stand")
  264.     set color of highlight to &cTemp
  265.     
  266. RETURN
  267. *-- EoP: SetColor
  268.  
  269. PROCEDURE SetColor2
  270. *-------------------------------------------------------------------------------
  271. *-- Programmer..: Phil Steele
  272. *-- Date........: 05/23/91
  273. *-- Notes.......: Used to set the screen colors for a system. It
  274. *--               checks a parameter passed by the programmer to see if the
  275. *--               monitor is a color system. It then creates the proper color
  276. *--               combinations based on this ... 
  277. *-- Written for.: dBASE IV, 1.1
  278. *-- Rev. History: Borrowed from Phil Steele's PCSDEMO (a public domain
  279. *--               program) and commented a bit more, minor modifications by
  280. *--               Ken Mayer (KENMAYER). 11/21/91 -- Modified for parameter ...
  281. *-- Calls.......: None
  282. *-- Called by...: Any
  283. *-- Usage.......: do setcolor2 with "<cYN>"
  284. *-- Example.....: in a menu or setup program:
  285. *--               PUBLIC cl_blank,cl_func,cl_help,cl_data,cl_error,;
  286. *--                      cl_entry,cl_stand,cl_menu,cl_warn 
  287. *--               DO setcolor2 with "Y"
  288. *--                  by declaring the variables PUBLIC before calling SETCOLOR
  289. *--                  they should be globally available throughout, unless you
  290. *--                  use a CLEAR ALL or RELEASE ALL command ...
  291. *-- Returns.....: None
  292. *-- Parameters..: cYN  =  "Y" for color, "N" for mono ...
  293. *-------------------------------------------------------------------------------
  294.     
  295.     parameter cYN
  296.     private lC, cTemp
  297.     
  298.     lC           = iif(cYN="Y",.t.,.f.)  && remember -- foreground/background
  299.     cl_Blank = "n/n,n/n,n"           && black on black on black ...
  300.     cl_Func  = "n/w"                 && function keys
  301.     cl_Help  = iif(lC,"n/g,g/n,n"      , "w+/n,n/w,n")   && help
  302.     cl_Data  = iif(lC,"rg+/gb,gb/rg,n" , "n/w,w+/n,n")   && data entry fields
  303.     cl_Error = iif(lC,"rg+/r,w/n,n"    , "w+/n,n/w,n")   && error messages
  304.     cl_Entry = iif(lC,"n/w,w/n,n"      , "n/w,w/n,n")    && data entry??
  305.     cl_Stand = iif(lC,"w+/b,b/w,n"     , "w+/n,n/w,n")   && standard screen
  306.     cl_Menu  = iif(lC,"rg+/b,b/w,n"    , "w+/n,n/w,n")   && menus
  307.     cl_Warn  = iif(lC,"rg+/r,w/n,n"    , "w/n,n/w,n")    && warning messages
  308.     save to color all like cl_*        && create COLOR.MEM
  309.     
  310.     *-- change current color settings to these ...
  311.     set color to &cl_stand             
  312.     cTemp = extrclr("&cl_data")
  313.     set color of fields   to &cTemp
  314.     set color of messages to &cTemp
  315.     set color of box      to &cTemp
  316.     cTemp = extrclr("&cl_stand")
  317.     set color of highlight to &cTemp
  318.     
  319. RETURN
  320. *-- EoP: SetColor2
  321.  
  322. FUNCTION ExtrClr
  323. *-------------------------------------------------------------------------------
  324. *-- Programmer..: Ken Mayer (KENMAYER)
  325. *-- Date........: 05/24/1991
  326. *-- Notes.......: Used to extract the first parameter of the MEMVARS
  327. *--               created from SETCOLOR above. The SET COLOR OF commands can
  328. *--               only use the first parameter.
  329. *--               It is recommended that you run SetColor (above) first, 
  330. *--               although if you define your own color memvars, this will work
  331. *--               just as well.
  332. *-- Written for.: dBASE IV, 1.1
  333. *-- Rev. History: None
  334. *-- Calls.......: None
  335. *-- Called by...: Any
  336. *-- Usage.......: extrclr(<cMemVar>)
  337. *-- Example.....: set color of highlight to &extrclr(cl_stand)
  338. *-- Returns.....: "W+/B"
  339. *-- Parameters..: cMemVar = color memory variable to have colors extracted from
  340. *-------------------------------------------------------------------------------
  341.     
  342.     parameters cMemVar
  343.     
  344. RETURN substr(cMemVar,1,(at(",",cMemVar)-1)) 
  345. *-- EoF: ExtrClr()
  346.  
  347. FUNCTION InvClr
  348. *-------------------------------------------------------------------------------
  349. *-- Programmer..: Ken Mayer (KENMAYER)
  350. *-- Date........: 05/23/1991
  351. *-- Notes.......: Used to set an inverse color, using value(s) returned
  352. *--               from extrclr above, or from a single color memvar.
  353. *--               Inverted colors may give odd results -- RG+ (yellow) is
  354. *--               not a background color, for example, and will appear as
  355. *--               RG (brown) -- this may not be what you wanted ...
  356. *-- Written for.: dBASE IV, 1.1
  357. *-- Rev. History: None
  358. *-- Calls.......: None
  359. *-- Called by...: Any
  360. *-- Usage.......: invclr(<cMemVar>)
  361. *-- Example.....: set color of highlight to &invclr(extrclr(cl_stand))
  362. *--                    or
  363. *--               x = extrclr(cl_stand)
  364. *--               set color of highlight to &invclr(x)
  365. *-- Returns.....: "B/W+"
  366. *-- Parameters..: cMemVar = color variable containing colors to be inverted
  367. *-------------------------------------------------------------------------------
  368.  
  369.     parameters cMemVar
  370.     private cTemp1, cTemp2
  371.     
  372.         cTemp1 = substr(cMemVar,1,(at("/",cMemVar)-1))
  373.         cTemp2 = substr(cMemVar,(at("/",cMemVar)+1),len(cMemVar))
  374.  
  375. RETURN cTemp2+"/"+cTemp1
  376. *-- EoF: InvClr()
  377.  
  378. *-------------------------------------------------------------------------------
  379. *-- End of Program: OBSOLETE.PRG
  380. *-------------------------------------------------------------------------------
  381.