'===========================================================================
' Subject: Perpetual Calendar                 Date: 06-13-03 (  :  )       
'  Author: Dieter Folger                      Code: RAPID-Q                
'  Origin: ba2049@bnv-bamberg.de            Packet: DATETIME.ABC
'===========================================================================
'---------------------------------------------
'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