2003-06-15 21:10

'---------------------------------------------
'CALENDAR.BAS for RapidQ
'Perpetual calendar (c) 2003 by Dieter Folger
'From 1583 until the twelfth of never.
'Note: The Gregorian Calendar was introduced
'in many European countries in October 1582,
'in England not until 1752.
'---------------------------------------------
     $INCLUDE "rapidq.inc"
     $TYPECHECK ON

     DIM Dm(12) AS INTEGER, Month(12) AS STRING
     DIM DateLbl(37) AS QLABEL
     DIM Day AS STRING, iLeft AS INTEGER, iTop AS INTEGER
     DIM d AS STRING, m AS BYTE, y AS INTEGER, i AS INTEGER
     DIM cM AS INTEGER, cY AS INTEGER, cD AS INTEGER
     DIM mo AS INTEGER, yy AS INTEGER, fd AS INTEGER, yr AS INTEGER
     DIM Cent AS INTEGER, FirstTime AS BYTE, Insert AS STRING

     DECLARE SUB WriteMonth
     DECLARE SUB ChangeYear
     DECLARE SUB ChangeMonth
     DECLARE SUB Minimize

     DATA 31, "  January ", 28, "  February ", 31, "     March "
     DATA 30, "     April ", 31, "      May ", 30, "     June "
     DATA 31, "      July ", 31, "   August ", 30, "September "
     DATA 31, "  October ", 30, "November ", 31, "December "
     FOR i = 1 TO 12 : READ Dm(i), Month(i) : NEXT

     Day = "Mo Tu We Th  Fr  Sa  Su"

 ' get current date values
     d = DATE$ : m = VAL(LEFT$(d, 2)) : y = VAL(MID$(d, 7, 4))
     cD = VAL(MID$(d, 4, 2)) : cM = m : cY = y

     CREATE DayFont AS QFONT
      Name = "Arial"
      Size = 12
      COLOR = clRed
     END CREATE
     CREATE TopFont AS QFONT
      Name = "Arial"
      Size = 12
      AddStyles (fsBold)
     END CREATE

     CREATE Form AS QFORM
      CAPTION = LTRIM$(Month(m)) + STR$(cD) + ", "+ STR$(cY)
      Width = 230
      Height = 225
      Center
      COLOR = &hEEFAFA
      delBorderIcons(biMaximize)
      WndProc = Minimize
      onShow = WriteMonth
      CREATE DayLbl AS QLABEL
       Left = 25
       Top = 50
       CAPTION = Day
       Font = DayFont
      END CREATE
      CREATE DateLabel AS QLABEL
       Left = 50
       Top = 21
       Font = TopFont
      END CREATE
      CREATE ScrollMonth AS QSCROLLBAR
       Top = 20
       Left = 20
       Width = 25
       Height = 18
       Position = m
       Min = 0
       Max = 13
       Hint = "Go up or down one month"
       ShowHint = 1
       onChange = ChangeMonth
      END CREATE
      CREATE ScrollYear AS QSCROLLBAR
       Top = 20
       Left = 180
       Width = 25
       Height = 18
       Max = 65000
       Min =  1583
       Position = y
       Hint = "Go up or down one year"
       ShowHint = 1
       onChange = ChangeYear
      END CREATE
     END CREATE

     Form.SHOWMODAL

     SUB WriteMonth
      Dm(2) = 28
      IF y MOD 4 = 0 THEN Dm(2) = 29  'February has 28 days except
    'in leap years. Centuries are only leap years when they can
    'be divided by 400 (i.e. 1900 was not leap year, 2000 was one)
      IF y MOD 100 = 0 AND y MOD 400 <> 0 THEN Dm(2) = 28

      mo = m : yy = y
    'Calculate first day of current month
    '(Monday = 0...Sunday = 6)
    '(algorithm by Carl Friedrich Gauss 1777-1855):
      IF mo < 3 THEN
       INC mo, 10 : DEC yy
      ELSE
       DEC mo, 2
      END IF
      Cent = yy \ 100 : yr = yy MOD 100
      fd = ((((26 * mo - 2) \ 10) + yr + (yr \ 4) _
       + (Cent \ 4) - (2 * Cent)) MOD 7)
      IF fd < 0 THEN INC fd, 7

      iLeft = 25 : iTop = 75
      FOR i = 1 TO 37
       IF FirstTime = 0 THEN
        'create labels only once
        DateLbl(i).PARENT = Form
        DateLbl(i).Left = iLeft
        DateLbl(i).Top = iTop
        DateLbl(i).Width = 25
        DateLbl(i).Height = 20
       END IF
       IF i-fd < 10 THEN Insert = " " ELSE INSERT = ""
       DateLbl(i).CAPTION = " "  + Insert + STR$(i - fd) + "  "
       IF i <= fd THEN DateLbl(i).CAPTION = "    "
       IF i > dm(m) + fd THEN DateLbl(i).CAPTION = "    "

       IF( i - fd = cd) AND m = cm AND y = cy THEN DateLbl(i).Font.Color_
        = clred ELSE DateLbl(i).Font.COLOR = clBlack

       IF FirstTime = 0 THEN
        IF (i) MOD 7 = 0 THEN
         iLeft = 25 : INC iTop, 20
        ELSE
         INC iLeft, 25
        END IF
       END IF
      NEXT
      DateLabel.CAPTION = Month(m) + STR$(y)
      FirstTime = 1
     END SUB

     SUB ChangeMonth
      m = ScrollMonth.Position
      IF m = 0 THEN
       IF y > ScrollMonth.Min THEN
        m = 12 : DEC y
       ELSE
        m = 1
       END IF
       ScrollMonth.Position = m
      END IF
      IF m = 13 THEN
       m = 1 : INC y
       ScrollMonth.Position = m
      END IF
      WriteMonth
     END SUB

     SUB ChangeYear
      y = ScrollYear.Position
      WriteMonth
     END SUB

2003-06-15 21:10