home *** CD-ROM | disk | FTP | other *** search
/ Frostbyte's 1980s DOS Shareware Collection / floppyshareware.zip / floppyshareware / KAND / PBASIC40.ZIP / DCAL.BAS < prev    next >
Encoding:
BASIC Source File  |  1991-05-27  |  4.7 KB  |  123 lines
  1.      DEFINT A-Z
  2.      '
  3. SUB DCalendar (DSCR1(), PAGE, SCRMODE) STATIC
  4.  
  5.      '--- set colors
  6.  
  7.      BLACK = 0: BLUE = 1: GREEN = 2: CYAN = 3: RED = 4: MAG = 5  ' to enhance program readability...
  8.      BROWN = 6: GREY = 7: LGREY = 8: LBLUE = 9: LGREEN = 10      ' we will define the standard colors...
  9.      LCYAN = 11: LRED = 12: LMAG = 13: YELLOW = 14: WHITE = 15   ' using more descriptive variable names
  10.      CALL GETVIDMODE(VMODE, VWIDTH, VPAGE)                       ' check video mode
  11.      MONO = (VMODE = 7)                                          ' if mono then set a flag...
  12.         IF MONO THEN BLUE = 0: RED = 0                           ' ... and adjust colors
  13.      CALHEADFORE = BLUE: CALHEADBACK = WHITE                     ' then we'll give them a name according...
  14.      CALMAINBACK = BLUE: CALMAINDATE = WHITE                     ' according to how they are used....
  15.      CALWEEKEND = GREY: CALHIDATE = YELLOW                       ' this will make it easier to
  16.      CALFRAME = MAG: WINDHEADFORE = YELLOW                        ' tailor the colors to suit...
  17.      WINDHEADBACK = RED: MAINBACK = BLACK
  18.  
  19.      REDIM CDAY$(32), M$(12), MD(12), VPOS(6)
  20.      REDIM CSCR(2000), CSCR1(160)
  21.      DSEG = VARSEG(DSCR1(1))
  22.      DOFS = VARPTR(DSCR1(1))
  23.      CSEG = VARSEG(CSCR(1))
  24.      COFS = VARPTR(CSCR(1))
  25.      CALL VGETSCREEN(DSEG, DOFS, 1, 1, 25, 80, CSEG, COFS)       ' save the virtual screen array for restore on exit
  26.      TSEG = VARSEG(CSCR1(1))
  27.      TOFS = VARPTR(CSCR1(1))
  28.         IF DAT$ = "" THEN DAT$ = LEFT$(DATE$, 2) + "/" + RIGHT$(DATE$, 2)
  29.      MONTH = VAL(LEFT$(DAT$, 2))
  30.      YEAR = VAL(RIGHT$(DAT$, 2))
  31.      THISYEAR = VAL(RIGHT$(DATE$, 4))
  32.         IF YEAR < 1900 THEN
  33.            YEAR = YEAR + 1900
  34.         END IF
  35.      YEAR$ = MID$(STR$(YEAR), 2)
  36.         IF MONTH = VAL(LEFT$(DATE$, 2)) THEN
  37.            CURMONTH = -1
  38.         ELSE
  39.           CURMONTH = 0
  40.         END IF
  41.      Y# = -INT((14 - MONTH) / 12)
  42.      Z# = -32073 + INT(1461 * (YEAR + 4800 + Y#) / 4)
  43.      Z# = Z# + INT(367 * (MONTH - 2 - 12 * Y#) / 12)
  44.      D# = Z# - INT(3 * INT((YEAR + 4900 + Y#) / 100) / 4)
  45.      D = D# - 7 * INT(D# / 7)
  46.      RESTORE 106
  47.         FOR I = 1 TO 12
  48.            READ M$(I), MD(I)
  49.         NEXT I
  50.      M$ = M$(MONTH): MD = MD(MONTH)
  51.         IF MONTH = 2 THEN MD = MD - (0 = YEAR MOD 4) + (0 = YEAR MOD 100) - (0 = YEAR MOD 400)
  52.      H$ = M$(MONTH) + " " + YEAR$
  53.      L = LEN(H$)
  54.      LS = 20 - L / 2
  55.      A$ = SPACE$(LS) + H$ + SPACE$(LS + 1)
  56.      X = 4: Y = 42
  57.      DISPLAY$ = LEFT$(A$, 38)
  58.      CALL CALCATTR(WINDHEADFORE, WINDHEADBACK, ATTR)
  59.      CALL DXQPRINT(DSEG, DOFS, DISPLAY$, X, Y, ATTR)
  60.         IF D = 0 THEN Y = 40
  61.         IF D = 1 THEN Y = 45
  62.         IF D = 2 THEN Y = 50
  63.         IF D = 3 THEN Y = 55
  64.         IF D = 4 THEN Y = 60
  65.         IF D = 5 THEN Y = 65
  66.         IF D = 6 THEN Y = 70
  67.     X = 10: Z = 39: J = 0: LM = D - 1
  68.     LASTMONTH = MONTH - 1
  69.        IF LASTMONTH = 0 THEN LASTMONTH = 1
  70.     CALL CALCATTR(CALFRAME, CALMAINBACK, ATTR)
  71.        FOR I = 0 TO D                                            ' last month
  72.            Z = Z + 5
  73.            J = J + 1
  74.            A$ = STR$(MD(LASTMONTH) - LM)
  75.            LM = LM - 1
  76.            CALL DXQPRINT(DSEG, DOFS, A$, X, Z, ATTR)
  77.          NEXT I
  78.          FOR I = 1 TO MD                                         ' this month
  79.            Y = Y + 5
  80.            J = J + 1
  81.            L = 0
  82.               IF Y = 80 THEN Y = 45: X = X + 2
  83.            A$ = MID$(STR$(I), 2)
  84.            T$ = "0" + A$: CDAY$(I) = RIGHT$(T$, 2)
  85.            IF Y = 45 OR Y = 75 THEN
  86.               C = -1
  87.            ELSE
  88.               C = 0
  89.            END IF
  90.            IF C THEN
  91.               CALL CALCATTR(CALWEEKEND, CALMAINBACK, ATTR)
  92.            ELSE
  93.               CALL CALCATTR(CALMAINDATE, CALMAINBACK, ATTR)
  94.            END IF
  95.            IF VAL(CDAY$(I)) = VAL(MID$(DATE$, 4, 2)) THEN
  96.               SD = -1
  97.            ELSE
  98.               SD = 0
  99.            END IF
  100.            IF SD AND CURMONTH THEN CALL CALCATTR(CALHIDATE, CALMAINBACK, ATTR)
  101.            CALL DXQPRINT(DSEG, DOFS, CDAY$(I), X, Y, ATTR)
  102.         NEXT I
  103.      L = 0
  104.      CALL CALCATTR(CALFRAME, CALMAINBACK, ATTR)
  105.         FOR I = J TO 42                                          ' next month
  106.            Y = Y + 5: L = L + 1
  107.            IF Y = 80 THEN Y = 45: X = X + 2
  108.            A$ = MID$(STR$(L), 2)
  109.            T$ = "0" + A$: A$ = RIGHT$(T$, 2)
  110.            CALL DXQPRINT(DSEG, DOFS, A$, X, Y, ATTR)
  111.         NEXT I
  112.  
  113.      EXIT SUB
  114.  
  115. DXQ1: CALL DXQPRINT(DSEG, DOFS, A$, X, Y, ATTR)
  116.      RETURN
  117.  
  118. 106  DATA JANUARY,31,FEBRUARY,28,MARCH,31,APRIL,30,MAY,31
  119.      DATA JUNE,30,JULY,31,AUGUST,31,SEPTEMBER,30,OCTOBER,31
  120.      DATA NOVEMBER,30,DECEMBER,31
  121. 107  DATA 48,53,58,63,68,73
  122. END SUB
  123.