Category : BASIC Source Code
Archive   : QBFAQR01.ZIP
Filename : JUL.BAS

 
Output of file : JUL.BAS contained in archive : QBFAQR01.ZIP
' From: JOE NEGRON on Un'iNet QBASIC echo

DEFINT A-Z

DECLARE FUNCTION Date2Day% (DateX$)
DECLARE FUNCTION Date2Eng$ (DateX$)
DECLARE FUNCTION Date2Mth% (DateX$)
DECLARE FUNCTION Date2Serial& (DateX$)
DECLARE FUNCTION Date2Year% (DateX$)
DECLARE FUNCTION DayOfTheCentury& (DateX$)
DECLARE FUNCTION DayOfTheWeek$ (DateX$)
DECLARE FUNCTION DayOfTheYear% (DateX$)
DECLARE FUNCTION DaysBetweenDates& (Date1$, Date2$)
DECLARE FUNCTION Julian% (DateX$)
DECLARE FUNCTION Serial2Date$ (Serial&)
DECLARE FUNCTION LeapYear% (Year%)
DECLARE FUNCTION MDY2Date$ (Month%, Day%, Year%)
DECLARE FUNCTION MthName$ (DateX$)
DECLARE FUNCTION ValidDate% (DateX$)
DECLARE FUNCTION WeekDay$ ()

'External routine(s)
DECLARE SUB Interrupt (IntNum%, InRegs AS RegType, OutRegs AS RegType)

'***********************************************************************
'* FUNCTION Date2Day%
'*
'* PURPOSE
'* Returns the day number given a date in the standard date format.
'***********************************************************************
FUNCTION Date2Day% (DateX$) STATIC
Date2Day% = VAL(MID$(DateX$, 4))
END FUNCTION

'***********************************************************************
'* FUNCTION Date2Eng$
'*
'* PURPOSE
'* Returns a string variable representing the English form of the
'* date given a date in the standard date format.
'*
'* INTERNAL ROUTINE(S)
'* FUNCTION Date2Day% (DateX$)
'* FUNCTION Date2Year% (DateX$)
'* FUNCTION MthName$ (DateX$)
'***********************************************************************
FUNCTION Date2Eng$ (DateX$) STATIC
Date2Eng$ = MID$(STR$(Date2Day%(DateX$)), 2) + " "_
+ MthName$(DateX$) + " "_
+ RIGHT$(STR$(Date2Year%(DateX$)), 2)
END FUNCTION

'***********************************************************************
'* FUNCTION Date2Mth%
'*
'* PURPOSE
'* Returns the month number given a date in the standard date format.
'***********************************************************************
FUNCTION Date2Mth% (DateX$) STATIC
Date2Mth% = VAL(DateX$)
END FUNCTION

'***********************************************************************
'* FUNCTION Date2Serial&
'*
'* PURPOSE
'* Returns the astronomical Julian day number given a date in the
'* standard date format. Note that the year must be 1583 or greater.
'*
'* INTERNAL ROUTINE(S)
'* FUNCTION Date2Day% (DateX$)
'* FUNCTION Date2Mth% (DateX$)
'* FUNCTION Date2Year% (DateX$)
'***********************************************************************
FUNCTION Date2Serial& (DateX$) STATIC
Month% = Date2Mth%(DateX$)
Day% = Date2Day%(DateX$)
Year% = Date2Year%(DateX$)
IF Month% > 2 THEN
Month% = Month% - 3
ELSE
Month% = Month% + 9
Year% = Year% - 1
END IF
TA& = 146097 * (Year% \ 100) \ 4
TB& = 1461& * (Year% MOD 100) \ 4
TC& = (153 * Month% + 2) \ 5 + Day% + 1721119
Date2Serial& = TA& + TB& + TC&
END FUNCTION

'***********************************************************************
'* FUNCTION Date2Year%
'*
'* PURPOSE
'* Returns the year number given a date in the standard date format.
'***********************************************************************
FUNCTION Date2Year% (DateX$) STATIC
Date2Year% = VAL(MID$(DateX$, 7))
END FUNCTION

'***********************************************************************
'* FUNCTION DayOfTheCentury&
'*
'* PURPOSE
'* Returns the number of the day of the century given a date in the
'* standard date format.
'*
'* INTERNAL ROUTINE(S)
'* FUNCTION Date2Year% (DateX$)
'* FUNCTION DaysBetweenDates& (Date1$, Date2$)
'* FUNCTION MDY2Date$ (Month%, Day%, Year%)
'***********************************************************************
FUNCTION DayOfTheCentury& (DateX$) STATIC
Year% = Date2Year%(DateX$)
DayOfTheCentury& = DaysBetweenDates&(MDY2Date$(12, 31, Year%_
- (Year% MOD 100) - 1), DateX$)
END FUNCTION

'***********************************************************************
'* FUNCTION DayOfTheWeek$
'*
'* PURPOSE
'* Returns a string stating the day of the week given a date in the
'* standard date format.
'*
'* INTERNAL ROUTINE(S)
'* FUNCTION Date2Serial& (DateX$)
'***********************************************************************
FUNCTION DayOfTheWeek$ (DateX$) STATIC
DayOfTheWeek$ = MID$("MonTueWedThuFriSatSun",_
((Date2Serial&(DateX$) MOD 7) + 1) * 3 - 2, 3)
END FUNCTION

'***********************************************************************
'* FUNCTION DayOfTheYear%
'*
'* PURPOSE
'* Returns the number of the day of the year (1-366) given a date in
'* the standard date format.
'*
'* INTERNAL ROUTINE(S)
'* FUNCTION Date2Year% (DateX$)
'* FUNCTION DaysBetweenDates& (Date1$, Date2$)
'* FUNCTION MDY2Date$ (Month%, Day%, Year%)
'***********************************************************************
FUNCTION DayOfTheYear% (DateX$) STATIC
DayOfTheYear% = DaysBetweenDates&(MDY2Date$(12, 31,_
Date2Year%(DateX$) - 1), DateX$)
END FUNCTION

'***********************************************************************
'* FUNCTION DaysBetweenDates&
'*
'* PURPOSE
'* Returns the number of days between any two dates. These two dates
'* are to be given in the standard date format.
'*
'* INTERNAL ROUTINE(S)
'* FUNCTION Date2Serial& (DateX$)
'***********************************************************************
FUNCTION DaysBetweenDates& (Date1$, Date2$) STATIC
DaysBetweenDates& = ABS(Date2Serial&(Date1$) - Date2Serial&(Date2$))
END FUNCTION

'***********************************************************************
'* FUNCTION Julian%
'*
'* PURPOSE
'* Returns an integer value representing the Julian day of the year.
'*
'* INTERNAL ROUTINE(S)
'* FUNCTION Date2Day% (DateX$)
'* FUNCTION Date2Mth% (DateX$)
'* FUNCTION Date2Year% (DateX$)
'* FUNCTION LeapYear% (Year%)
'***********************************************************************
FUNCTION Julian% (DateX$) STATIC
FullMonths% = Date2Mth%(DateX$) - 1
JulTmp% = 0

FOR X% = 1 TO FullMonths% 'accumulate the number of
SELECT CASE X% ' days for full months
CASE 1, 3, 5, 7, 8, 10
JulTmp% = JulTmp% + 31
CASE 4, 6, 9, 11
JulTmp% = JulTmp% + 30
CASE 2
JulTmp% = JulTmp% + 28 - LeapYear%(Date2Year%(DateX$))
END SELECT
NEXT X%

JulTmp% = JulTmp% + Date2Day%(DateX$) 'add days in present month
Julian% = JulTmp%
END FUNCTION

'***********************************************************************
'* FUNCTION LeapYear%
'*
'* PURPOSE
'* Determines whether or not the given year is a leap year.
'***********************************************************************
FUNCTION LeapYear% (Year%) STATIC
'If the year is evenly divisible by 4 but not evenly divisible
'by 100, or if the year is evenly divisible by 400, then it is
'a leap year.
LeapYear% = (Year% MOD 4 = 0 AND Year% MOD 100 <> 0) OR_
(Year% MOD 400 = 0)
END FUNCTION

'***********************************************************************
'* FUNCTION MDY2Date$
'*
'* PURPOSE
'* Converts Month%, Day%, and Year% to a string in the standard date
'* format.
'***********************************************************************
FUNCTION MDY2Date$ (Month%, Day%, Year%) STATIC
MDY2Date$ = RIGHT$("0" + MID$(STR$(Month%), 2), 2) + "-"_
+ RIGHT$("0" + MID$(STR$(Day%), 2), 2) + "-"_
+ RIGHT$("000" + MID$(STR$(Year%), 2), 4)
END FUNCTION

'***********************************************************************
'* FUNCTION MthName$
'*
'* PURPOSE
'* Returns then name of the month given a string in the standard date
'* format.
'***********************************************************************
FUNCTION MthName$ (DateX$) STATIC
MthName$ = MID$("JanFebMarAprMayJunJulAugSepOctNovDec", VAL(DateX$)_
* 3 - 2, 3)
END FUNCTION

'***********************************************************************
'* FUNCTION Serial2Date$
'*
'* PURPOSE
'* Returns a date in the standard date format given a Julian day
'* number.
'*
'* INTERNAL ROUTINE(S)
'* FUNCTION MDY2Date$ (Month%, Day%, Year%)
'***********************************************************************
FUNCTION Serial2Date$ (Serial&) STATIC
X& = 4 * Serial& - 6884477
Y& = (X& \ 146097) * 100
D& = (X& MOD 146097) \ 4

X& = 4 * D& + 3
Y& = (X& \ 1461) + Y&
D& = (X& MOD 1461) \ 4 + 1

X& = 5 * D& - 3
M& = X& \ 153 + 1
D& = (X& MOD 153) \ 5 + 1

IF M& < 11 THEN
Month% = M& + 2
ELSE
Month% = M& - 10
END IF

Day% = D&
Year% = Y& + M& \ 11

DateX$ = MDY2Date$(Month%, Day%, Year%)
Serial2Date$ = DateX$
END FUNCTION

'***********************************************************************
'* FUNCTION ValidDate%
'*
'* PURPOSE
'* Returns TRUE if the given date represents a real date or FALSE if
'* the date is in error.
'*
'* INTERNAL ROUTINE(S)
'* FUNCTION Date2Serial& (DateX$)
'* FUNCTION Serial2Date$ (Serial&)
'***********************************************************************
FUNCTION ValidDate% (DateX$) STATIC
ValidDate% = DateX$ = Serial2Date$(Date2Serial&(DateX$))
END FUNCTION

'***********************************************************************
'* FUNCTION WeekDay$
'*
'* PURPOSE
'* Uses DOS ISR 21H, Function 2AH (Get Date) to return the current
'* day of the week.
'*
'* EXTERNAL ROUTINE(S)
'* QBX.LIB
'* -------
'* SUB Interrupt (IntNum%, InRegs AS RegType, OutRegs AS RegType)
'***********************************************************************
FUNCTION WeekDay$ STATIC
InRegs.ax = &H2A00
Interrupt &H21, InRegs, OutRegs
al% = OutRegs.ax AND &HFF 'extract al register
WeekDay$ = MID$("SunMonTueWedThuFriSat", (al% + 1) * 3 - 2, 3)
END FUNCTION


  3 Responses to “Category : BASIC Source Code
Archive   : QBFAQR01.ZIP
Filename : JUL.BAS

  1. Very nice! Thank you for this wonderful archive. I wonder why I found it only now. Long live the BBS file archives!

  2. This is so awesome! 😀 I’d be cool if you could download an entire archive of this at once, though.

  3. 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/