Category : Dbase (Clipper, FoxBase, etc) Languages Source Code
Archive : TN9006.ZIP
Filename : UDFSAM.TXT
Output of file : UDFSAM.TXT contained in archive : TN9006.ZIP
Roland Bouchereau
Okay, here it is: a whole new set of user-defined functions for almost
any occasion. Altogether, fifteen handy-dandy, dyed-in-the-wool,
time-saving functions await you.
You may notice a good amount of error checking in these functions.
I'm merely trying to make these things as goof-proof as possible.
Feel free to modify to your heart's content, as long as you know what
you're inserting or removing! Let's dive right in, shall we?
Between(
The Between() function works like the RANGE clause on an @...GET
command. It determines if
and third arguments is not significant. The first thing Between()
does is determine the types of the three parameters passed. Then it
determines if the types are usable. This means that each parameter
must be
1. defined
2. not a logical value (true or false)
3. not a memo
All of the parameters must, of course, be of compatible data types
(character, date, float or numeric). Lastly, it does the actual
comparison operation. The comparison test is inclusive, that is, it
allows the first parameter to be equal to either of the other two
parameters. Whew! Yes, it's a bit long-winded, but it does the job
and does it quickly, despite all the code used.
FUNCTION Between
PARAMETERS parm1_,parm2_,parm3_
PRIVATE types_,type1_,type2_,type3_
type1_ = TYPE("parm1_")
type2_ = TYPE("parm2_")
type3_ = TYPE("parm3_")
types_ = type1_ + type2_ + type3_
IF .NOT. "U" $ types_ .AND.;
.NOT. "L" $ types_ .AND.;
.NOT. "M" $ types_ .AND.;
((type1_ $ "FN" .AND. type2_ $ "FN" .AND. type3_ $ "FN").OR.;
(type1_ = type2_ .AND. type2_ = type3_))
RETURN (parm2_ <= parm1_ .AND. parm3_ => parm1_) .OR.;
(parm3_ <= parm1_ .AND. parm2_ => parm1_)
ENDIF
RETURN .F.
EXAMPLE:
. ? Between(DATE(),{01/01/90},{12/31/90})
.T.
Frac(
This is a simple function that returns the fractional part of a
number, or those numbers to the right of the decimal place. It's a
natural counterpart to the INT() function, which returns the integer
portion of a number.
FUNCTION Frac
PARAMETER number_
IF TYPE("number_") $ "FN"
RETURN number_ - INT(number_)
ENDIF
RETURN 0
EXAMPLE:
. ? Frac(PI())
0.141592653589790
IsArray(
By now, you may be a little disappointed that the TYPE() function in
dBASE IV cannot tell you whether or not a variable name is actually an
array. Well, here's the method right here. Based upon the fact that
every array has at least one element, the UDF will check for the
existence of that first element. If it exists, its type has to be
valid. Notice that like the TYPE() function, the name of the array
must be passed as a character string, not an array element.
FUNCTION IsArray
PARAMETER varname_
RETURN TYPE(varname_ + "[1]") + TYPE(varname_ + "[1,1]") # "UU"
EXAMPLE:
. DECLARE myarray[10]
. ? IsArray("myarray")
.T.
IsLeapYr(
Use IsLeapYr to determine if the year of the date passed is a leap
year. Leap years occur every four years except at the beginning of
every century unless that century is evenly divisible by 4. The year
2000 will be the first leap year closing out a century since 1600.
FUNCTION IsLeapYr
PARAMETER date_
IF TYPE("date_") = "D"
PRIVATE yr_
yr_ = YEAR(date_)
RETURN MOD(yr_,4) = 0 .AND. (MOD(yr_,100) # 0 .OR.;
MOD(yr_,400) = 0)
ENDIF
RETURN .F.
EXAMPLE:
. ? IsLeapYr({01/01/90})
.F.
. ? IsLeapYr({01/01/92})
.T.
Days(
The Days() function returns the number of days in the month specified
by
calculations. Other UDFs in this article use the Days() function for
exactly this purpose. This UDF depends on the IsLeapYr() function
previously discussed to determine the appropriate number of days for
February. If you chose not to use the IsLeapYr() function
separately, you will need to incorporate the code into this function
to make it completely reliable. This function makes use of the
IsLeapYr function to help determine the appropriate number of days for
February. IsLeapYr() is used, rather than manipulating the DTOC()
representation of the date, in case the current date format is set so
that the number representing the month is not the middle pair of
digits.
FUNCTION Days
PARAMETER date_
IF TYPE("date_") = "D"
PRIVATE month_
month_ = MONTH(date_)
IF month_ # 2 && Check for February
RETURN VAL(SUBSTR(" 31 28 31 30 31 30 31 31 30 31 30 31",;
(month_ * 3) - 1,2))
ELSE
RETURN 28 + IIF(IsLeapyr(date_),1,0)
ENDIF
ENDIF
RETURN 0
EXAMPLE:
. ? Days({01/02/90})
28
. ? Days({01/02/92})
29
FDoM(
FDoM() will return a date that is the first day of the month in the
date passed. This is done by subtracting the number of days returned
by the DAY() function from the passed date. This always brings the
result to the end of the previous month. Then just add 1 for the
first day.
FUNCTION FDoM
PARAMETER date_
IF TYPE("date_") = "D"
RETURN date_ - DAY(date_) + 1
ENDIF
RETURN {}
EXAMPLE:
. ? Fdom({01/17/90})
01/01/90
LDoM(
Complementing the previous function, LDoM() returns a date that is the
last day of the month in the date passed. The algorithm is similar to
that of Fdom(), but it also includes a call to the DAYS() function
listed above to help with the calculation.
FUNCTION LDoM
PARAMETER date_
IF TYPE("date_") = "D"
RETURN date_ + Days(date_) - DAY(date_)
ENDIF
RETURN {}
EXAMPLE:
. ? Ldom({01/17/90})
01/31/90
FDoQ(
FDoQ() returns the first day of the quarter of a calendar year tin
which the specified date lies. Again, the method is similar to the
two previous functions. This time, however, the subtraction process
continues until we arrive at the first month of the quarter which is
determined by expression MOD(MONTH(date_),3) # 1.
FUNCTION FDoQ
PARAMETER parm_
IF TYPE("parm_") = "D"
PRIVATE date_
date_ = parm_
DO WHILE MOD(MONTH(date_),3) # 1
date_ = date_ - DAY(date_)
ENDDO
RETURN date_ - DAY(date_) + 1
ENDIF
RETURN {}
EXAMPLE:
. ? Fdoq({08/27/90})
07/01/90
LDoQ(
No doubt you guessed it. This function returns the last day of the
quarter in a calendar year containing the specified date.
FUNCTION LDoQ
PARAMETER parm_
IF TYPE("parm_") = "D"
PRIVATE date_
date_ = parm_
DO WHILE MOD(MONTH(date_),3) # 0
date_ = date_ + Days(date_)
ENDDO
RETURN date_ + Days(date_) - DAY(date_)
ENDIF
RETURN {}
EXAMPLE:
. ? Ldoq({08/27/90})
09/30/90
LJust(
LJust() will add spaces to a character string on its right, padding it
out to the specified length, effectively left justifying the string.
If the length of the character string passed is already greater than
the numeric parameter, LJust() returns the string truncated to that
length. LJust() insures that the length specified is valid by nesting
the MIN() and MAX() functions. This little technique could make for a
good UDF by itself. LJust() and it's siblings, RJust() and Center(),
can certainly make life a little easier if you want to write custom
reports.
FUNCTION LJust
PARAMETERS string_,length_
IF TYPE("string_") + TYPE("length_") $ "CN,CF"
RETURN TRANSFORM(string_,"@B " + ;
REPLICATE("X",MAX(0,MIN(length_,254))))
ENDIF
RETURN ""
EXAMPLE:
. ? LJust(_pdriver,25) + ":"
GENERIC.PR2 :
RJust(
RJust() will add spaces to a character string on its left, padding it
out to the specified length, effectively right justifying the string.
FUNCTION RJust
PARAMETERS string_,length_
IF TYPE("string_") + TYPE("length_") $ "CN,CF"
RETURN TRANSFORM(string_,"@J " + ;
REPLICATE("X",MAX(0,MIN(length_,254))))
ENDIF
RETURN ""
EXAMPLE:
. ? RJust(_pdriver,25)
GENERIC.PR2
Center(
Center() will add spaces to a character string on the left and right,
padding it out to the specified length. This effectively centers the
string within the specified length.
FUNCTION Center
PARAMETERS string_,length_
IF TYPE("string_") + TYPE("length_") $ "CN,CF"
RETURN TRANSFORM(string_,"@I " + ;
REPLICATE("X",MAX(0,MIN(length_,254))))
ENDIF
RETURN ""
EXAMPLE:
. ? "- " + Center("The End",30) + " -"
- The End -
Occurs(
Quite simply, this function counts the number of distinct occurrences
of the first character expression within the second. When an instance
of the first expression is found, searching continues from the
character following the last character in the occurrence match, if
any. Notice in the example, that two occurrences of "pap" are found
not three.
FUNCTION Occurs
PARAMETERS pattern_,template_
IF TYPE("pattern_") + TYPE("template_") = "CC"
PRIVATE plen_,tlen_,times_
plen_ = LEN(pattern_)
tlen_ = LEN(template_)
times_ = 0
DO WHILE pattern_ $ RIGHT(template_,tlen_)
times_ = times_ + 1
tlen_ = tlen_ - AT(pattern_,RIGHT(template_,tlen_)) - ;
plen_ + 1
ENDDO
RETURN times_
ENDIF
RETURN 0
EXAMPLE:
. ? Occurs("pap","papapap")
2
LockFile()
LockFile() adds a measure of user control to the standard dBASE IV
FLOCK() function. In multi-user applications, explicit file and
record locking provide a measure of control that is not possible using
implicit locking techniques. However, if a file or record is locked
at another workstation for a long period, then it may be desirable to
give the user at the current workstation the ability to abort the
current operation. LockFile() accomplishes exactly this. The
function first alerts the user that a lock is being attempted. Then,
it attempts to lock the file indefinitely until it succeeds or the
user presses the Escape key.
FUNCTION LockFile
PRIVATE persisted_, fp_, dbf_
fp_ = SET("FULLPATH") = "ON"
SET FULLPATH OFF
dbf_ = DBF()
IF fp_
SET FULLPATH ON
ENDIF
SET MESSAGE TO " Attempting to lock " + dbf_ + "..."
persisted_ = .T.
CLEAR TYPEAHEAD
DO WHILE .NOT. FLOCK()
persisted_ = (INKEY() # 27)
IF .NOT. persisted_
EXIT
ENDIF
ENDDO
IF persisted_
SET MESSAGE TO ""
ELSE
SET MESSAGE TO "Lock aborted!"
ENDIF
RETURN persisted_
EXAMPLE :
USE Sample
IF LockFile()
APPEND FROM (backup)
UNLOCK
ENDIF
USE
LockRec()
LockRec() performs the same job that LockFile() does, except that it
locks the current record only. Both this function and LockFile()
don't allow the same parameter capability that the standard dBASE IV
locking functions do. This is due to the fact that dBASE IV does not
allow a variable number of parameters to be passed to a UDF or
procedure. However, the functions are easily modified to your
style.
FUNCTION LockRec
PRIVATE persisted_
SET MESSAGE TO "Attempting to lock current record..."
persisted_ = .T.
CLEAR TYPEAHEAD
DO WHILE .NOT. RLOCK()
persisted_ = (INKEY() # 27)
IF .NOT. persisted_
EXIT
ENDIF
ENDDO
IF persisted_
SET MESSAGE TO ""
ELSE
SET MESSAGE TO "Lock aborted!"
ENDIF
RETURN persisted_
EXAMPLE:
USE Sample
SCAN WHILE LockRec()
EDIT RECORD RECNO()
UNLOCK
ENDSCAN
Well, there you have it. There ought to be a function here to suit
any application or palette. Enjoy and happy programming!
Very nice! Thank you for this wonderful archive. I wonder why I found it only now. Long live the BBS file archives!
This is so awesome! 😀 I’d be cool if you could download an entire archive of this at once, though.
But one thing that puzzles me is the “mtswslnkmcjklsdlsbdmMICROSOFT” string. There is an article about it here. It is definitely worth a read: http://www.os2museum.com/wp/mtswslnk/