2003-05-06 07:14

'**********************************************************************
'A Calendar For Windows 95 (ver 1.0) March 2000
'written by John Davenport
'email: timelord@zebra.net
'**********************************************************************
'August 2002
'fixed ;) by John Seregni
'email: gmseregni@hotmail.com
'**********************************************************************


     $INCLUDE "RAPIDQ.INC"

     DECLARE SUB ShowMonth (month%, day%, year%)
     DECLARE FUNCTION LeapYear (y AS INTEGER) AS INTEGER
     DECLARE FUNCTION DateNum (month%, day%, year%) AS LONG
     DECLARE FUNCTION DayNum (month%, day%, year%) AS INTEGER
     DECLARE FUNCTION MonthDays (month%, year%) AS INTEGER
     DECLARE FUNCTION MonthName (month%) AS STRING

     DIM cal AS QFORM
     DIM week AS QLABEL
     DIM date(37) AS QLABEL
     DIM font AS QFONT

     curMonth% = VAL(LEFT$(DATE$,2))
     curDay% = VAL(MID$(DATE$, 4, 2))
     curYear% = VAL(RIGHT$(DATE$, 4))

     CALL ShowMonth curMonth%, curDay%, curYear%

     cal.Center
     cal.BorderStyle = bsDialog
     cal.Height = 140
     cal.Width = 155

     week.PARENT = cal
     week.CAPTION = "Su  Mo  Tu  We  Th  Fr  Sa"
     week.Top = 2
     week.Left = 5

     cal.SHOWMODAL
'*********************************************************************
     FUNCTION DateNum (month%, day%, year%) AS LONG
      startYear% = 1900
      january% = 1
      daysPerYr& = 365
      IF year% < startYear% THEN
       tooEarly% = TRUE
      END IF
      IF month% < 1 OR month% > 12 THEN
       badMonth% = TRUE
      END IF
      IF day% < 1 OR day% > MonthDays (month%, year%) THEN
       badDay% = TRUE
      END IF
      IF tooEarly% = TRUE OR badMonth% = TRUE OR badDay% = TRUE THEN
       DateNum = 0
       EXIT FUNCTION
      END IF
      num& = daysPerYr& * (year% - startYear%)
      MEMcurYear% = curYear%   '<---------------------------- CURRENT YEAR VALUE SAVED
      FOR curYear% = startYear% TO year% - 1 STEP 4
       IF LeapYear (curYear%) THEN
        num& = num& + 1
       END IF
      NEXT curYear%
      curYear%=MEMcurYear%     '<---------------------------- CURRENT YEAR VALUE RESTORED
      FOR curMonth% = january% TO month% - 1
       num& = num& + MonthDays (curMonth%, year%)
      NEXT curMonth%
      num& = num& + day%
      DateNum = num&
     END FUNCTION

     FUNCTION DayNum (month%, day%, year%) AS INTEGER
      d& = DateNum (month%, day%, year%)
      IF d& <> 0 THEN
       dow% = d& MOD 7 + 1
      ELSE
       dow% = 0
      END IF
      DayNum = dow%
     END FUNCTION


     FUNCTION LeapYear (y AS INTEGER) AS INTEGER
      IF (y MOD 400 = 0) OR (y MOD 4 = 0) AND (y MOD 100 <> 0) THEN
       LeapYear = TRUE
      ELSE
       LeapYear = FALSE
      END IF
     END FUNCTION

     FUNCTION MonthDays (month%, year%) AS INTEGER
      SELECT CASE month%
      CASE 2
       days% = 28
       IF LeapYear (year%) = TRUE THEN
        days% = days% + 1
       END IF
      CASE 4, 6, 9, 11
       days% = 30       '<--------------------      FIXED !  30 INSTEAD  31 !!!!!!!
      CASE ELSE
       days% = 31
      END SELECT
      MonthDays = days%
     END FUNCTION

     FUNCTION MonthName (month%) AS STRING
      m$ = "January   February  March     April     " '  <------- added ONE end space
      m$ = m$ + "May       June      July      August    " '  <------- added ONE end space
      m$ = m$ + "September October   November  December  " '  <------- added ONE end space
      mn$ = MID$(m$, (month% - 1) * 10 + 1, 10)
      mn$ = RTRIM$(mn$)
      MonthName = mn$
     END FUNCTION

     SUB ShowMonth (month%, day%, year%)
      firstDay% = DayNum (month%, 1, year%)
      monthLength% = MonthDays (month%, year%)
      cal.CAPTION = MonthName (month%) + " " + STR$(curYear%)
      curDate% = 0
      FOR curDay% = 1 TO 37
       IF curDay% = firstDay% AND curDate% = 0 THEN
        isFirstDay% = TRUE
       ELSE
        isFirstDay% = FALSE
       END IF
       IF curDate% > 0 AND curDate% < monthLength% THEN
        isInMonth% = TRUE
       ELSE
        isInMonth% = FALSE
       END IF
       IF isFirstDay% = TRUE OR IsInMonth% = TRUE THEN
        curDate% = curDate% + 1
        IF curDate% < 10 THEN
         Font.Name = "  " + STR$(curDate%)
        ELSE
         Font.Name = STR$(curDate%)
        END IF
       ELSE
        Font.Name = "  "
       END IF
       IF curDate% = VAL(MID$(DATE$, 4, 2)) THEN
        Font.COLOR = &HFF0000
       ELSE
        Font.COLOR = &H000000
       END IF
       date(curDay%).PARENT = cal
       date(curDay%).Font = Font
       date(curDay%).CAPTION = Font.Name
       READ date(curDay%).Top
       READ date(curDay%).Left
      NEXT curDay%
     END SUB
'********************************************************************
     DATA 20,5,20,25,20,45,20,65,20,85,20,105,20,125
     DATA 35,5,35,25,35,45,35,65,35,85,35,105,35,125
     DATA 50,5,50,25,50,45,50,65,50,85,50,105,50,125
     DATA 65,5,65,25,65,45,65,65,65,85,65,105,65,125
     DATA 80,5,80,25,80,45,80,65,80,85,80,105,80,125
     DATA 95,5,95,25

2003-05-06 07:14