home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Power-Programmierung
/
CD1.mdf
/
xbase
/
library
/
dbase
/
duflp
/
obsolete.prg
< prev
next >
Wrap
Text File
|
1992-07-24
|
16KB
|
381 lines
*-------------------------------------------------------------------------------
*-- Program...: OBSOLETE.PRG
*-- Programmer: Ken Mayer (KENMAYER)
*-- Date......: 04/30/1992
*-- Notes.....: The following functions are not necessary using dBASE IV, 1.5,
*-- but have been retained in the current version of the library
*-- system in order to have some compatibility with 1.1.
*-------------------------------------------------------------------------------
FUNCTION Empty
*-------------------------------------------------------------------------------
*-- Programmer..: Jerry Wightman (WIGHTMAN)
*-- Date........: ?
*-- Notes.......: Used to check whether a memory variable in dBASE contains
*-- anything, based on type of field. (Pulled from BORBBS)
*-- NOTE: In release 1.5, replace all calls to EMPTY() with
*-- the new: ISBLANK() function. This will be faster.
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: None
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: Empty(<cFld>)
*-- Example.....: @5,10 say "Enter date: " get bDate;
*-- valid required .not. empty(bDate);
*-- error chr(7)+"** Date cannot be Empty! **"
*-- Returns.....: Logical (.t./.f.)
*-- Parameters..: cFld = Field/Memvar/Expression to check for "Emptiness"
*-------------------------------------------------------------------------------
PARAMETERS cFld && may be memory variable or database field name
private cTalk, lReturn
cTalk = SET("TALK")
lReturn = .F. && FALSE means: variable is NOT empty
do case
case type( "cFld" ) = "C"
if len( ltrim(rtrim( cFld )) ) = 0
lReturn = .T.
endif
case type( "cFld" ) = "N" .or. type( "cFld" ) = "F"
if cFld = 0
lReturn = .T.
endif
case type( "cFld" ) = "L"
lReturn = .F. && Can't check logical fields
case type( "cFld" ) = "D"
if cFld = {}
lReturn = .T.
endif
case type( "cFld" ) = "M"
if len( cFld ) = 0
lReturn = .T.
endif
otherwise && TYPE = "U"
lReturn = .T.
endcase
set talk &cTalk
RETURN lReturn
*-- EoF: Empty()
FUNCTION NumFlds
*-------------------------------------------------------------------------------
*-- Programmer..: Bowen Moursund (BOWEN)
*-- Date........: 07/12/1991
*-- Notes.......: Returns the number of fields in a database structure --
*-- only in the currently selected DBF
*-- NOTE: In release 1.5, replace function NUMFLDS() with
*-- FLDCOUNT() -- built in to 1.5, faster ...
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: None
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: NumFlds()
*-- Example.....: ? NumFlds()
*-- Returns.....: Number of fields
*-- Parameters..: None
*-------------------------------------------------------------------------------
private nFlds,cFldName
*-- If currently selected database is empty (no dbf file)
if len(trim(dbf())) = 0
nFlds = 0 && set to 0
*-- we have something ...
else
nFlds = 0 && initialize
do while .t. && loop through the record structure
nFlds= nFlds + 1 && increment counter
cFldName = field(nFlds) && get fieldname
if len(trim(cFldName)) = 0 && if length = 0,
nFlds = nFlds - 1 && decrement counter
exit && get out of loop, we're done
endif && endif(length...)
enddo && end of loop
endif
RETURN nFlds
*-- EoF: NumFlds()
FUNCTION DateSet
*-------------------------------------------------------------------------------
*-- Programmer..: Jay Parsons (JPARSONS)
*-- Date........: 03/01/1992
*-- Notes.......: Returns string giving name of current DATE format
*-- This is not needed in Version 1.5, in which set("DATE")
*-- returns the format. Unlike that function in 1.5, this
*-- one cannot distinguish between date formats set with
*-- different terms that amount to the same thing:
*-- DMY = BRITISH = FRENCH
*-- MDY = AMERICAN
*-- YMD = JAPAN
*-- If your users will be using one of these formats and
*-- are sensitive about the name, substitute the one they
*-- want for the equivalent in this function.
*-- Rev. History: None
*-- Written for.: dBASE IV, versions below 1.5
*-- Rev. History: None
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: DateSet()
*-- Example.....: ?DateSet()
*-- Returns.....: Character
*-- Parameters..: None
*-------------------------------------------------------------------------------
private cCent, cTestdate, cDelimiter
cCent = set( "CENTURY" )
set century off
cTestdate = ctod( "01/02/03" )
cDelimiter = substr( dtoc( cTestdate ), 3, 1 )
set century &cCent
do case
case month( cTestdate ) = 1
RETURN iif( cDelimiter = "-", "USA", "MDY" )
case day( cTestdate ) = 1
RETURN iif( cDelimiter = "/", "DMY", ;
iif( cDelimiter = ".", "GERMAN", "ITALIAN" ) )
otherwise
RETURN iif( cDelimiter = ".", "ANSI", "YMD" )
endcase
*-- EoF: DateSet()
FUNCTION Stampval
*-------------------------------------------------------------------------------
*-- Programmer..: Jay Parsons (Jparsons)
*-- Date........: 04/07/1992
*-- Notes.......: Passed a 16-character string in the form of the rightmost
*-- : 16 characters returned by the DOS DIR command for a file,
*-- : returns a number that will compare properly in date/time
*-- : order with the numbers returned by this function for other
*-- : files.
*-- Written for.: dBASE IV Versions below 1.5
*-- Rev. History: None
*-- Calls : None
*-- Called by...: Any
*-- Usage.......: Stampval(<cTimestamp>)
*-- Example.....: IF Stampval("02-22-92 10:54a") > Stampval("04-05-92 5:54p")
*-- Returns.....: Numeric corresponding to time stamp of file
*-- Parameters..: cStamp, a DIR timestamp
*-------------------------------------------------------------------------------
parameters cStamp
RETURN 1440 * ( 12 * val( left(cStamp,2)) + val(substr(cStamp,4,2)) ;
+ 372*val(substr(cStamp,7,2)) ) + 60 * val(substr(cStamp,11,2)) ;
+ val(substr(Cstamp,14,2)) + iif(right(cStamp,1)="p",720,0)
*--Eof() Stampval
PROCEDURE FullWin
*-------------------------------------------------------------------------------
*-- Programmer..: Ken Mayer (KENMAYER)
*-- Date........: 05/23/91
*-- Notes.......: Overlays menus or another screen with a full window,
*-- so that processing is done in the window, and one can return
*-- directly to the menus, without redrawing screen and such.
*-- This routine may be a problem in dBASE IV, 1.5 ... use
*-- with caution ...
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: None
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: do fullwin with <cColor>,<cWinName>,<cScreen>
*-- Example.....: do fullwin with "w+/b","w_Edit","sc_Main"
*-- * perform whatever actions are needed in the window
*-- deactivate window wEdit
*-- release window wEdit
*-- restore screen from sMain
*-- release screen sMain
*-- Returns.....: None
*-- Parameters..: cColor = Colors for window
*-- cWinName = Name of window
*-- cScreen = Name of screen
*-------------------------------------------------------------------------------
parameters cColor,cWinName,sScreen
define window &cWinName from 0,0 to 23,79 none color &cColor.
save screen to &sScreen.
activate window &cWinName.
RETURN
*-- EoP: FullWin
PROCEDURE SetColor
*-------------------------------------------------------------------------------
*-- Programmer..: Phil Steele
*-- Date........: 05/23/91
*-- Notes.......: Used to set the screen colors for a system. It
*-- checks to see if a color monitor is attached (ISCOLOR()),
*-- and sets system variables, that can be used in SET COLOR OF
*-- commands. You must define the memvars as PUBLIC, see Example
*-- below -- otherwise nothing will work.
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: Borrowed from Phil Steele's PCSDEMO (a public domain
*-- program) and commented a bit more, minor modifications by
*-- Ken Mayer (KENMAYER).
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: do setcolor
*-- Example.....: in a menu or setup program:
*-- PUBLIC cl_blank,cl_func,cl_help,cl_data,cl_error,;
*-- cl_entry,cl_stand,cl_menu,cl_warn
*-- DO setcolor
*-- by declaring the variables PUBLIC before calling SETCOLOR
*-- they should be globally available throughout, unless you
*-- use a CLEAR ALL or RELEASE ALL command ...
*-- Returns.....: None
*-- Parameters..: None
*-------------------------------------------------------------------------------
if file("COLOR.MEM")
restore from Color.mem additive && if color.mem exists, restore from it
else && otherwise, create it
lC = iscolor() && remember -- foreground/background
cl_Blank = "n/n,n/n,n" && black on black on black ...
cl_Func = "n/w" && function keys (used in CLRSHOW)
* if iscolor() = true, define color, otherwise black/white
cl_Help = iif(lC,"n/g,g/n,n" , "w+/n,n/w,n") && help
cl_Data = iif(lC,"rg+/gb,gb/rg,n" , "n/w,w+/n,n") && data entry fields
cl_Error = iif(lC,"rg+/r,w/n,n" , "w+/n,n/w,n") && error messages
cl_Entry = iif(lC,"n/w,w/n,n" , "n/w,w/n,n") && data entry??
cl_Stand = iif(lC,"w+/b,b/w,n" , "w+/n,n/w,n") && standard screen
cl_Menu = iif(lC,"rg+/b,b/w,n" , "w+/n,n/w,n") && menus
cl_Warn = iif(lC,"rg+/r,w/n,n" , "w/n,n/w,n") && warning messages
save to color all like cl_* && create COLOR.MEM
endif
*-- change current color settings to these ...
set color to &cl_stand
cTemp = extrclr("&cl_data")
set color of fields to &cTemp
set color of messages to &cTemp
set color of box to &cTemp
cTemp = extrclr("&cl_stand")
set color of highlight to &cTemp
RETURN
*-- EoP: SetColor
PROCEDURE SetColor2
*-------------------------------------------------------------------------------
*-- Programmer..: Phil Steele
*-- Date........: 05/23/91
*-- Notes.......: Used to set the screen colors for a system. It
*-- checks a parameter passed by the programmer to see if the
*-- monitor is a color system. It then creates the proper color
*-- combinations based on this ...
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: Borrowed from Phil Steele's PCSDEMO (a public domain
*-- program) and commented a bit more, minor modifications by
*-- Ken Mayer (KENMAYER). 11/21/91 -- Modified for parameter ...
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: do setcolor2 with "<cYN>"
*-- Example.....: in a menu or setup program:
*-- PUBLIC cl_blank,cl_func,cl_help,cl_data,cl_error,;
*-- cl_entry,cl_stand,cl_menu,cl_warn
*-- DO setcolor2 with "Y"
*-- by declaring the variables PUBLIC before calling SETCOLOR
*-- they should be globally available throughout, unless you
*-- use a CLEAR ALL or RELEASE ALL command ...
*-- Returns.....: None
*-- Parameters..: cYN = "Y" for color, "N" for mono ...
*-------------------------------------------------------------------------------
parameter cYN
private lC, cTemp
lC = iif(cYN="Y",.t.,.f.) && remember -- foreground/background
cl_Blank = "n/n,n/n,n" && black on black on black ...
cl_Func = "n/w" && function keys
cl_Help = iif(lC,"n/g,g/n,n" , "w+/n,n/w,n") && help
cl_Data = iif(lC,"rg+/gb,gb/rg,n" , "n/w,w+/n,n") && data entry fields
cl_Error = iif(lC,"rg+/r,w/n,n" , "w+/n,n/w,n") && error messages
cl_Entry = iif(lC,"n/w,w/n,n" , "n/w,w/n,n") && data entry??
cl_Stand = iif(lC,"w+/b,b/w,n" , "w+/n,n/w,n") && standard screen
cl_Menu = iif(lC,"rg+/b,b/w,n" , "w+/n,n/w,n") && menus
cl_Warn = iif(lC,"rg+/r,w/n,n" , "w/n,n/w,n") && warning messages
save to color all like cl_* && create COLOR.MEM
*-- change current color settings to these ...
set color to &cl_stand
cTemp = extrclr("&cl_data")
set color of fields to &cTemp
set color of messages to &cTemp
set color of box to &cTemp
cTemp = extrclr("&cl_stand")
set color of highlight to &cTemp
RETURN
*-- EoP: SetColor2
FUNCTION ExtrClr
*-------------------------------------------------------------------------------
*-- Programmer..: Ken Mayer (KENMAYER)
*-- Date........: 05/24/1991
*-- Notes.......: Used to extract the first parameter of the MEMVARS
*-- created from SETCOLOR above. The SET COLOR OF commands can
*-- only use the first parameter.
*-- It is recommended that you run SetColor (above) first,
*-- although if you define your own color memvars, this will work
*-- just as well.
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: None
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: extrclr(<cMemVar>)
*-- Example.....: set color of highlight to &extrclr(cl_stand)
*-- Returns.....: "W+/B"
*-- Parameters..: cMemVar = color memory variable to have colors extracted from
*-------------------------------------------------------------------------------
parameters cMemVar
RETURN substr(cMemVar,1,(at(",",cMemVar)-1))
*-- EoF: ExtrClr()
FUNCTION InvClr
*-------------------------------------------------------------------------------
*-- Programmer..: Ken Mayer (KENMAYER)
*-- Date........: 05/23/1991
*-- Notes.......: Used to set an inverse color, using value(s) returned
*-- from extrclr above, or from a single color memvar.
*-- Inverted colors may give odd results -- RG+ (yellow) is
*-- not a background color, for example, and will appear as
*-- RG (brown) -- this may not be what you wanted ...
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: None
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: invclr(<cMemVar>)
*-- Example.....: set color of highlight to &invclr(extrclr(cl_stand))
*-- or
*-- x = extrclr(cl_stand)
*-- set color of highlight to &invclr(x)
*-- Returns.....: "B/W+"
*-- Parameters..: cMemVar = color variable containing colors to be inverted
*-------------------------------------------------------------------------------
parameters cMemVar
private cTemp1, cTemp2
cTemp1 = substr(cMemVar,1,(at("/",cMemVar)-1))
cTemp2 = substr(cMemVar,(at("/",cMemVar)+1),len(cMemVar))
RETURN cTemp2+"/"+cTemp1
*-- EoF: InvClr()
*-------------------------------------------------------------------------------
*-- End of Program: OBSOLETE.PRG
*-------------------------------------------------------------------------------