'===========================================================================
' Subject: PB CALENDAR BOX                    Date: 09-10-98 (19:26)       
'  Author: Dieter Folger                      Code: PB                     
'  Origin: folger@bamberg.baynet.de         Packet: DATETIME.ABC
'===========================================================================
 '---------------------------------------------------'
 ' CALENDAR.BAS for Power Basic                      '
 ' Freeware (c) 1998 by Dieter Folger                '
 ' Calendar in a box showing current month and       '
 ' day (blinking)                                    '
 ' Use arrows right, left, up, down to go forth      '
 ' and back in months and years                      '
 '---------------------------------------------------'
 DEFINT A - Z
 'Data for days in a month and months names:
 DATA 31, "January", 28, "February", 31, "March"
 DATA 30, "April", 31, "May", 30, "June", 31, "July"
 DATA 31, "August", 30, "September", 31, "October"
 DATA 30, "November", 31, "December"
 Day$="Mo Tu We Th Fr Sa Su"
 FOR i = 1 TO 12 : READ Dm(i), Month$(i) : NEXT 'read DATA
 ' get current date 
 d$ = Date$ : m = VAL(Left$(d$, 2)) : y = VAL(MID$(d$, 7, 4))
 Cm = m : Cy = y : Dd = VAL(MID$(d$, 4, 2))
 SaveScreen Tmp$  'save current screen
 'make box for calendar:
 VIEW TEXT (10,2)-(33,11)
 COLOR 14,3
 PRINT "É";STRING$(22,"Í");"»";
 LOCATE CSRLIN,1
 FOR i = 1 TO 8
     PRINT "º";SPACE$(22);"º";
 NEXT
 PRINT "È";STRING$(22,"Í");"¼";
 COLOR 0,3
 LOCATE 10,9: PRINT " ";CHR$(24,25,26,27);"Esc ";
 
 DO  ' main loop
    IF y < 1583 THEN y = 1583 : m = 1  ' start of Gregorian calendar
    IF y > 9999 THEN y = 9999 : m = 12 ' nearly until the end of time
    LOCATE 1,10: PRINT STR$(Y) + " ";
    LOCATE 3,3: PRINT Day$
    Dm(2) = 28  ' February has normally 28 days
    IF y MOD 4 = 0 THEN Dm(2) = 29  'except in leap years
    'centuries are only leap years when they can
    'be divided by 400 (i.e. 1900 was not a leap year, 2000 is one):
    IF y MOD 100 = 0 AND y MOD 400 <> 0 then Dm(2) = 28
    d = 1 : mo = m : yy = y
    'Calculate first weekday of current month of year
    '(algorithm by Carl Friedrich Gauss 1777-1855):
    IF mo < 3 THEN
       INCR mo, 10 : DECR yy
    ELSE
       DECR mo, 2
    END IF
    Cent = yy \ 100 : yr = yy MOD 100
    fd = ((((26 * mo - 2) \ 10) + d + yr + (yr \ 4) _
         + (Cent \ 4) - (2 * Cent)) MOD 7) - 1
    IF fd < 0 then fd = fd + 7
    'show result in calendar box
    LOCATE 2,3
    PRINT Month$(m) + SPACE$(20 - LEN(Month$(m)))
    ro = 4 : co = 1 : s$ = ""
    IF fd < 7 THEN FOR i = 0 TO fd - 1 : s$ = s$ + "   " : NEXT
    FOR i = 1 TO dm (m)
 c$ = STR$(i)
        IF LEN(s$) = 21 THEN LOCATE Ro, 2: PRINT s$: s$ = "" : INCR ro
 IF i < 10 then s$ = s$ + " " + c$ ELSE s$ = s$ + c$
 IF i = dd THEN cRow = ro : cCol = LEN(s$)
    NEXT
    IF LEN(s$) THEN LOCATE ro,2 : Print s$; SPACE$(21 - LEN(s$));
    IF ro < 9 THEN LOCATE 9,2 : Print SPACE$(21);
    IF y = cy AND m = cm THEN
       COLOR 16,3  ' current day should blink
       LOCATE cRow, Col + cCol
       PRINT RIGHT$(" "+STR$(Dd),2); : COLOR 0,3
    END IF
    DO: Kb$ = INKEY$ : LOOP UNTIL Kb$ <> ""
    IF LEN (Kb$) = 2 THEN Kb$ = MID$ (KB$, 2)
    SELECT CASE Kb$          ' Keyboard functions:
           CASE CHR$ (&H50)  ' cursor down
                INCR y       ' next year
           CASE CHR$ (&H48)  ' cursor up
                DECR y       ' last year
           CASE CHR$ (&H4B)  ' cursor left
         DECR m       ' last month
         IF m = 0 THEN m = 12 : DECR y
           CASE CHR$ (&H4D)  ' cursor right
         INCR m       ' next month
         IF m = 13 THEN m = 1 : INCR y
           CASE CHR$(27)     ' ESC key
                EXIT LOOP    ' end program
    END SELECT
 LOOP ' end of main loop
 VIEW TEXT (1,1) - (80,24)
 RestoreScreen Tmp$ 'restore screen again
END
'----------------------------------------------------------------------------
SUB SaveScreen (Scrn$)
'----------------------------------------------------------------------------
  SHARED py,px
  py = CSRLIN: px = POS(0)
  IF (PbvScrnCard AND 1) = 0 THEN
 Address = &HB800  
  ELSE
 Address = &HB000  
  END IF
  DEF SEG = Address 
      Scrn$ = PEEK$(0,4000)
  DEF SEG
END SUB
'----------------------------------------------------------------------------
SUB RestoreScreen (Scrn$)
'----------------------------------------------------------------------------
  SHARED py, px
  IF (PbvScrnCard AND 1) = 0 THEN
 Address = &HB800 
  ELSE
 Address = &HB000 
  END IF
  DEF SEG = Address
      POKE$ 0, Scrn$
  DEF SEG
  LOCATE py, px, 1
END SUB