home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Power-Programmierung
/
CD1.mdf
/
basic
/
library
/
pb
/
library4
/
figdat-u.bas
< prev
next >
Wrap
BASIC Source File
|
1990-09-04
|
6KB
|
211 lines
'==============================================================================
' DATE ARITHMETIC MODULE -- FIGDAT-U.BAS
'==============================================================================
' -- 2-14-90
$COMPILE UNIT
$ERROR ALL OFF
DEFINT A-Z
EXTERNAL PressAKeyBeep$, OopsBeep$, TinyBeep$
FUNCTION GetDate$ PUBLIC
GetDate$ = Left$(DATE$,6)+RIGHT$(DATE$,2)
END FUNCTION
'____________________________________________________________________________
FUNCTION FigDate&(A$) PUBLIC
LOCAL A#, M%, D%, Y&, LpYrDys%, W&, A&, B%
' ON ERROR GOTO FigDateError
M% = VAL(LEFT$(A$,2))
D% = VAL(MID$(A$,4,2))
Y& = VAL(RIGHT$(A$,2))
' ON ERROR GOTO Oops
SELECT CASE M%
CASE <1, >12
GOTO FigDateError
CASE 1,3,5,7,8,10,12
IF D% < 1 OR D > 31% THEN FigDateError
CASE 4,6,9,11
IF D% < 1 OR D% > 30 THEN FigDateError
CASE 2
IF Y&/4 = FIX(Y&/4) AND Y& <> 0 THEN
IF D% < 1 OR D% > 29 THEN FigDateError
ELSE
IF D% < 1 OR D% > 28 THEN FigDateError
END IF: END SELECT
IF Y& = 0 AND M% < 3 THEN GOTO DateRealOld
IF M% < 3 THEN DECR Y&
A& = FIX(Y&/4): W& = 1461 * A&: A& = Y& - 4*A&
W& = W& + 365 * A&
SELECT CASE M%
CASE 3
B% = 0
CASE 4
B% = 31
CASE 5
B% = 61
CASE 6
B% = 92
CASE 7
B% = 122
CASE 8
B% = 153
CASE 9
B% = 184
CASE 10
B% = 214
CASE 11
B% = 245
CASE 12
B% = 275
CASE 1
B% = 306
CASE 2
B% = 337
END SELECT
FigDate& = W& + B% + D% + 59: EXIT FUNCTION
DateRealOld:
IF M% = 2 THEN FigDate& = D%+31 ELSE FigDate& = D%
EXIT FUNCTION
FigDateError:
FigDate& = 0
' ON ERROR GOTO Oops
END FUNCTION
'____________________________________________________________________________
FUNCTION WriteDate$ (Julioid&) PUBLIC
LOCAL W&, A#, B#, Y%, Y#, M$, D$, Y$
W& = Julioid& ' new line to avoid a new problem. see below.
IF W& > 36524 THEN WriteDate$ = " 2000 + ": EXIT FUNCTION
IF W& < 1 THEN WriteDate$ = "ERR:FigD=0": EXIT FUNCTION
IF W& < 60 THEN
Y$ = "01" ' note: I had trouble with this guy after
SELECT CASE W& ' converting it from a DEF Fn to its present
CASE > 31 ' form because -- it altered its argument!
M$ = "02": D$ = STR$(W&-31) ' (true FUNCTIONS do.)
CASE ELSE
M$ = "01": D$ = STR$(W&)
END SELECT
ELSE
W& = W& - 59
A# = INT (W&/1461)
W& = W& - 1461 * A#
B# = INT (W&/365.25)
Y# = 4 * A# + B#
W& = W& - B# * 365
SELECT CASE W&
CASE 0
M$ = "02": D$ = " 29"
EXIT SELECT
CASE 1 TO 31
M$ = "03": D$ = STR$(W&)
EXIT SELECT
CASE 32 TO 61
M$ = "04": D$ = STR$(W& - 31)
EXIT SELECT
CASE 62 TO 92
M$ = "05": D$ = STR$(W& - 61)
EXIT SELECT
CASE 93 TO 122
M$ = "06": D$ = STR$(W& - 92)
EXIT SELECT
CASE 123 TO 153
M$ = "07": D$ = STR$(W& - 122)
EXIT SELECT
CASE 154 TO 184
M$ = "08": D$ = STR$(W& - 153)
EXIT SELECT
CASE 185 TO 214
M$ = "09": D$ = STR$(W& - 184)
EXIT SELECT
CASE 215 TO 245
M$ = "10": D$ = STR$(W& - 214)
EXIT SELECT
CASE 246 TO 275
M$ = "11": D$ = STR$(W& - 245)
EXIT SELECT
CASE 276 TO 306
M$ = "12": D$ = STR$(W& - 275)
EXIT SELECT
CASE 307 TO 337
M$ = "01": D$ = STR$(W& - 306): INCR Y#
EXIT SELECT
CASE > 337
M$ = "02": D$ = STR$(W& - 337): INCR Y#
END SELECT
END IF
D$ = MID$(D$,2)
IF LEN(D$) = 1 THEN D$ = "0"+D$
Y% = Y#
Y$ = MID$(STR$(Y%),2)
IF LEN(Y$) = 1 THEN Y$ = "0"+Y$
WriteDate$ = M$+"-"+D$+"-"+Y$
END FUNCTION
'____________________________________________________________________________
FUNCTION WkDay$ (W&) PUBLIC
LOCAL N
N = W& MOD 7
SELECT CASE N
CASE 0
WkDay$ = "Sun":EXIT FUNCTION
CASE 1
WkDay$ = "Mon":EXIT FUNCTION
CASE 2
WkDay$ = "Tue":EXIT FUNCTION
CASE 3
WkDay$ = "Wed":EXIT FUNCTION
CASE 4
WkDay$ = "Thu":EXIT FUNCTION
CASE 5
WkDay$ = "Fri":EXIT FUNCTION
CASE 6
WkDay$ = "Sat": END SELECT: END FUNCTION
'____________________________________________________________________________
FUNCTION YearsSince (D0$) PUBLIC
LOCAL Y, D$
D$ = DATE$
Y = VAL (RIGHT$(D$,2)) - VAL (RIGHT$(D0$,2)) - 1
' (take deep breath ...)
IF VAL (LEFT$ (D$,2)) > VAL (LEFT$ (D0$,2)) THEN
INCR Y
ELSEIF VAL (LEFT$ (D$,2)) = VAL (LEFT$ (D0$,2))_
AND VAL (MID$(D$,4,2)) => VAL (MID$(D0$,4,2)) THEN
INCR Y
END IF
YearsSince = Y
END FUNCTION
'____________________________________________________________________________
FUNCTION FlipDate$ (WrittenDate$) PUBLIC
FlipDate$ = RIGHT$(WrittenDate$,2)+LEFT$(WrittenDate$,2)_
+MID$(WrittenDate$,4,2)
END FUNCTION
' this makes dates come out like 880312 (for today) for easy sorting
FUNCTION UnflipDate$ (FlippedDate$) PUBLIC
UnflipDate$ = MID$(FlippedDate$,3,2) + "-" + RIGHT$(FlippedDate$,2)_
+ "-" + LEFT$(FlippedDate$,2)
END FUNCTION