home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / basic / library / qb_pds / qbfaqr01 / date / jul.bas < prev   
Encoding:
BASIC Source File  |  1992-08-12  |  10.0 KB  |  304 lines
  1. ' From: JOE NEGRON on Un'iNet QBASIC echo
  2.  
  3. DEFINT A-Z
  4.  
  5. DECLARE FUNCTION Date2Day% (DateX$)
  6. DECLARE FUNCTION Date2Eng$ (DateX$)
  7. DECLARE FUNCTION Date2Mth% (DateX$)
  8. DECLARE FUNCTION Date2Serial& (DateX$)
  9. DECLARE FUNCTION Date2Year% (DateX$)
  10. DECLARE FUNCTION DayOfTheCentury& (DateX$)
  11. DECLARE FUNCTION DayOfTheWeek$ (DateX$)
  12. DECLARE FUNCTION DayOfTheYear% (DateX$)
  13. DECLARE FUNCTION DaysBetweenDates& (Date1$, Date2$)
  14. DECLARE FUNCTION Julian% (DateX$)
  15. DECLARE FUNCTION Serial2Date$ (Serial&)
  16. DECLARE FUNCTION LeapYear% (Year%)
  17. DECLARE FUNCTION MDY2Date$ (Month%, Day%, Year%)
  18. DECLARE FUNCTION MthName$ (DateX$)
  19. DECLARE FUNCTION ValidDate% (DateX$)
  20. DECLARE FUNCTION WeekDay$ ()
  21.  
  22. 'External routine(s)
  23. DECLARE SUB Interrupt (IntNum%, InRegs AS RegType, OutRegs AS RegType)
  24.  
  25. '***********************************************************************
  26. '* FUNCTION Date2Day%
  27. '*
  28. '* PURPOSE
  29. '*    Returns the day number given a date in the standard date format.
  30. '***********************************************************************
  31. FUNCTION Date2Day% (DateX$) STATIC
  32.    Date2Day% = VAL(MID$(DateX$, 4))
  33. END FUNCTION
  34.  
  35. '***********************************************************************
  36. '* FUNCTION Date2Eng$
  37. '*
  38. '* PURPOSE
  39. '*    Returns a string variable representing the English form of the
  40. '*    date given a date in the standard date format.
  41. '*
  42. '* INTERNAL ROUTINE(S)
  43. '*    FUNCTION Date2Day% (DateX$)
  44. '*    FUNCTION Date2Year% (DateX$)
  45. '*    FUNCTION MthName$ (DateX$)
  46. '***********************************************************************
  47. FUNCTION Date2Eng$ (DateX$) STATIC
  48.    Date2Eng$ = MID$(STR$(Date2Day%(DateX$)), 2) + " "_
  49.              + MthName$(DateX$) + " "_
  50.              + RIGHT$(STR$(Date2Year%(DateX$)), 2)
  51. END FUNCTION
  52.  
  53. '***********************************************************************
  54. '* FUNCTION Date2Mth%
  55. '*
  56. '* PURPOSE
  57. '*    Returns the month number given a date in the standard date format.
  58. '***********************************************************************
  59. FUNCTION Date2Mth% (DateX$) STATIC
  60.    Date2Mth% = VAL(DateX$)
  61. END FUNCTION
  62.  
  63. '***********************************************************************
  64. '* FUNCTION Date2Serial&
  65. '*
  66. '* PURPOSE
  67. '*    Returns the astronomical Julian day number given a date in the
  68. '*    standard date format.  Note that the year must be 1583 or greater.
  69. '*
  70. '* INTERNAL ROUTINE(S)
  71. '*    FUNCTION Date2Day% (DateX$)
  72. '*    FUNCTION Date2Mth% (DateX$)
  73. '*    FUNCTION Date2Year% (DateX$)
  74. '***********************************************************************
  75. FUNCTION Date2Serial& (DateX$) STATIC
  76.    Month% = Date2Mth%(DateX$)
  77.    Day% = Date2Day%(DateX$)
  78.    Year% = Date2Year%(DateX$)
  79.    IF Month% > 2 THEN
  80.       Month% = Month% - 3
  81.    ELSE
  82.       Month% = Month% + 9
  83.       Year% = Year% - 1
  84.    END IF
  85.    TA& = 146097 * (Year% \ 100) \ 4
  86.    TB& = 1461& * (Year% MOD 100) \ 4
  87.    TC& = (153 * Month% + 2) \ 5 + Day% + 1721119
  88.    Date2Serial& = TA& + TB& + TC&
  89. END FUNCTION
  90.  
  91. '***********************************************************************
  92. '* FUNCTION Date2Year%
  93. '*
  94. '* PURPOSE
  95. '*    Returns the year number given a date in the standard date format.
  96. '***********************************************************************
  97. FUNCTION Date2Year% (DateX$) STATIC
  98.    Date2Year% = VAL(MID$(DateX$, 7))
  99. END FUNCTION
  100.  
  101. '***********************************************************************
  102. '* FUNCTION DayOfTheCentury&
  103. '*
  104. '* PURPOSE
  105. '*    Returns the number of the day of the century given a date in the
  106. '*    standard date format.
  107. '*
  108. '* INTERNAL ROUTINE(S)
  109. '*    FUNCTION Date2Year% (DateX$)
  110. '*    FUNCTION DaysBetweenDates& (Date1$, Date2$)
  111. '*    FUNCTION MDY2Date$ (Month%, Day%, Year%)
  112. '***********************************************************************
  113. FUNCTION DayOfTheCentury& (DateX$) STATIC
  114.    Year% = Date2Year%(DateX$)
  115.    DayOfTheCentury& = DaysBetweenDates&(MDY2Date$(12, 31, Year%_
  116.                     - (Year% MOD 100) - 1), DateX$)
  117. END FUNCTION
  118.  
  119. '***********************************************************************
  120. '* FUNCTION DayOfTheWeek$
  121. '*
  122. '* PURPOSE
  123. '*    Returns a string stating the day of the week given a date in the
  124. '*    standard date format.
  125. '*
  126. '* INTERNAL ROUTINE(S)
  127. '*    FUNCTION Date2Serial& (DateX$)
  128. '***********************************************************************
  129. FUNCTION DayOfTheWeek$ (DateX$) STATIC
  130.    DayOfTheWeek$ = MID$("MonTueWedThuFriSatSun",_
  131.                    ((Date2Serial&(DateX$) MOD 7) + 1) * 3 - 2, 3)
  132. END FUNCTION
  133.  
  134. '***********************************************************************
  135. '* FUNCTION DayOfTheYear%
  136. '*
  137. '* PURPOSE
  138. '*    Returns the number of the day of the year (1-366) given a date in
  139. '*    the standard date format.
  140. '*
  141. '* INTERNAL ROUTINE(S)
  142. '*    FUNCTION Date2Year% (DateX$)
  143. '*    FUNCTION DaysBetweenDates& (Date1$, Date2$)
  144. '*    FUNCTION MDY2Date$ (Month%, Day%, Year%)
  145. '***********************************************************************
  146. FUNCTION DayOfTheYear% (DateX$) STATIC
  147.    DayOfTheYear% = DaysBetweenDates&(MDY2Date$(12, 31,_
  148.                    Date2Year%(DateX$) - 1), DateX$)
  149. END FUNCTION
  150.  
  151. '***********************************************************************
  152. '* FUNCTION DaysBetweenDates&
  153. '*
  154. '* PURPOSE
  155. '*    Returns the number of days between any two dates.  These two dates
  156. '*    are to be given in the standard date format.
  157. '*
  158. '* INTERNAL ROUTINE(S)
  159. '*    FUNCTION Date2Serial& (DateX$)
  160. '***********************************************************************
  161. FUNCTION DaysBetweenDates& (Date1$, Date2$) STATIC
  162.    DaysBetweenDates& = ABS(Date2Serial&(Date1$) - Date2Serial&(Date2$))
  163. END FUNCTION
  164.  
  165. '***********************************************************************
  166. '* FUNCTION Julian%
  167. '*
  168. '* PURPOSE
  169. '*    Returns an integer value representing the Julian day of the year.
  170. '*
  171. '* INTERNAL ROUTINE(S)
  172. '*    FUNCTION Date2Day% (DateX$)
  173. '*    FUNCTION Date2Mth% (DateX$)
  174. '*    FUNCTION Date2Year% (DateX$)
  175. '*    FUNCTION LeapYear% (Year%)
  176. '***********************************************************************
  177. FUNCTION Julian% (DateX$) STATIC
  178.    FullMonths% = Date2Mth%(DateX$) - 1
  179.    JulTmp% = 0
  180.  
  181.    FOR X% = 1 TO FullMonths%                 'accumulate the number of
  182.       SELECT CASE X%                         '   days for full months
  183.       CASE 1, 3, 5, 7, 8, 10
  184.          JulTmp% = JulTmp% + 31
  185.       CASE 4, 6, 9, 11
  186.          JulTmp% = JulTmp% + 30
  187.       CASE 2
  188.          JulTmp% = JulTmp% + 28 - LeapYear%(Date2Year%(DateX$))
  189.       END SELECT
  190.    NEXT X%
  191.  
  192.    JulTmp% = JulTmp% + Date2Day%(DateX$)     'add days in present month
  193.    Julian% = JulTmp%
  194. END FUNCTION
  195.  
  196. '***********************************************************************
  197. '* FUNCTION LeapYear%
  198. '*
  199. '* PURPOSE
  200. '*    Determines whether or not the given year is a leap year.
  201. '***********************************************************************
  202. FUNCTION LeapYear% (Year%) STATIC
  203.    'If the year is evenly divisible by 4 but not evenly divisible
  204.    'by 100, or if the year is evenly divisible by 400, then it is
  205.    'a leap year.
  206.    LeapYear% = (Year% MOD 4 = 0 AND Year% MOD 100 <> 0) OR_
  207.                (Year% MOD 400 = 0)
  208. END FUNCTION
  209.  
  210. '***********************************************************************
  211. '* FUNCTION MDY2Date$
  212. '*
  213. '* PURPOSE
  214. '*    Converts Month%, Day%, and Year% to a string in the standard date
  215. '*    format.
  216. '***********************************************************************
  217. FUNCTION MDY2Date$ (Month%, Day%, Year%) STATIC
  218.    MDY2Date$ = RIGHT$("0" + MID$(STR$(Month%), 2), 2) + "-"_
  219.              + RIGHT$("0" + MID$(STR$(Day%), 2), 2) + "-"_
  220.              + RIGHT$("000" + MID$(STR$(Year%), 2), 4)
  221. END FUNCTION
  222.  
  223. '***********************************************************************
  224. '* FUNCTION MthName$
  225. '*
  226. '* PURPOSE
  227. '*    Returns then name of the month given a string in the standard date
  228. '*    format.
  229. '***********************************************************************
  230. FUNCTION MthName$ (DateX$) STATIC
  231.    MthName$ = MID$("JanFebMarAprMayJunJulAugSepOctNovDec", VAL(DateX$)_
  232.             * 3 - 2, 3)
  233. END FUNCTION
  234.  
  235. '***********************************************************************
  236. '* FUNCTION Serial2Date$
  237. '*
  238. '* PURPOSE
  239. '*    Returns a date in the standard date format given a Julian day
  240. '*    number.
  241. '*
  242. '* INTERNAL ROUTINE(S)
  243. '*    FUNCTION MDY2Date$ (Month%, Day%, Year%)
  244. '***********************************************************************
  245. FUNCTION Serial2Date$ (Serial&) STATIC
  246.    X& = 4 * Serial& - 6884477
  247.    Y& = (X& \ 146097) * 100
  248.    D& = (X& MOD 146097) \ 4
  249.  
  250.    X& = 4 * D& + 3
  251.    Y& = (X& \ 1461) + Y&
  252.    D& = (X& MOD 1461) \ 4 + 1
  253.  
  254.    X& = 5 * D& - 3
  255.    M& = X& \ 153 + 1
  256.    D& = (X& MOD 153) \ 5 + 1
  257.  
  258.    IF M& < 11 THEN
  259.       Month% = M& + 2
  260.    ELSE
  261.       Month% = M& - 10
  262.    END IF
  263.  
  264.    Day% = D&
  265.    Year% = Y& + M& \ 11
  266.  
  267.    DateX$ = MDY2Date$(Month%, Day%, Year%)
  268.    Serial2Date$ = DateX$
  269. END FUNCTION
  270.  
  271. '***********************************************************************
  272. '* FUNCTION ValidDate%
  273. '*
  274. '* PURPOSE
  275. '*    Returns TRUE if the given date represents a real date or FALSE if
  276. '*    the date is in error.
  277. '*
  278. '* INTERNAL ROUTINE(S)
  279. '*    FUNCTION Date2Serial& (DateX$)
  280. '*    FUNCTION Serial2Date$ (Serial&)
  281. '***********************************************************************
  282. FUNCTION ValidDate% (DateX$) STATIC
  283.    ValidDate% = DateX$ = Serial2Date$(Date2Serial&(DateX$))
  284. END FUNCTION
  285.  
  286. '***********************************************************************
  287. '* FUNCTION WeekDay$
  288. '*
  289. '* PURPOSE
  290. '*    Uses DOS ISR 21H, Function 2AH (Get Date) to return the current
  291. '*    day of the week.
  292. '*
  293. '* EXTERNAL ROUTINE(S)
  294. '*    QBX.LIB
  295. '*    -------
  296. '*    SUB Interrupt (IntNum%, InRegs AS RegType, OutRegs AS RegType)
  297. '***********************************************************************
  298. FUNCTION WeekDay$ STATIC
  299.    InRegs.ax = &H2A00
  300.    Interrupt &H21, InRegs, OutRegs
  301.    al% = OutRegs.ax AND &HFF                 'extract al register
  302.    WeekDay$ = MID$("SunMonTueWedThuFriSat", (al% + 1) * 3 - 2, 3)
  303. END FUNCTION
  304.