home *** CD-ROM | disk | FTP | other *** search
/ World of Shareware - Software Farm 2 / wosw_2.zip / wosw_2 / QBAS / WNDTOOL5.ZIP / CALENDAR.SUB < prev    next >
Text File  |  1989-04-26  |  5KB  |  219 lines
  1. '
  2. '=============================================================================
  3. '
  4. SUB    CALENDAR(MONTH%,YEAR%,QUADRANT$,FORE%,BACK%,SHADOW%)           STATIC
  5.  
  6.        DEFINT A-Z
  7.  
  8. 'DIMENSION ARRAY AND FILL WITH DATA
  9.        DIM LKUP$(12,2)
  10.  
  11. 'INITIALIZE LOOKUP ARRAY FOR DAYS IN MONTH%
  12.  
  13.        LKUP$(1,1)="January  "
  14.        LKUP$(1,2)="31"
  15.        LKUP$(2,1)="February "
  16.        LKUP$(2,2)="28"
  17.        LKUP$(3,1)="March    "
  18.        LKUP$(3,2)="31"
  19.        LKUP$(4,1)="April    "
  20.        LKUP$(4,2)="30"
  21.        LKUP$(5,1)="May      "
  22.        LKUP$(5,2)="31"
  23.        LKUP$(6,1)="June     "
  24.        LKUP$(6,2)="30"
  25.        LKUP$(7,1)="July     "
  26.        LKUP$(7,2)="31"
  27.        LKUP$(8,1)="August   "
  28.        LKUP$(8,2)="31"
  29.        LKUP$(9,1)="September"
  30.        LKUP$(9,2)="30"
  31.        LKUP$(10,1)="October "
  32.        LKUP$(10,2)="31"
  33.        LKUP$(11,1)="November"
  34.        LKUP$(11,2)="30"
  35.        LKUP$(12,1)="December"
  36.        LKUP$(12,2)="31"
  37.  
  38.        IF (MONTH%<1) OR (MONTH%>12) THEN
  39.            GOTO CALENDAR.DONE
  40.        ENDIF
  41.  
  42.        IF YEAR%<0 THEN
  43.            GOTO CALENDAR.DONE
  44.        ENDIF
  45.  
  46. '
  47. 'If Quadrant is in ROW:COL format, extract Row and Column
  48.  
  49.        IF INSTR(QUADRANT$,":")<>0 THEN
  50.            GOSUB CALENDAR.GETORD
  51.          GOTO CALENDAR.GO1
  52.        ENDIF
  53.  
  54. 'Determine Position based on Quadrant Parameter and size of menu
  55.  
  56.        QUADRANT%=VAL(QUADRANT$)
  57.        IF QUADRANT% <0 OR QUADRANT% >4 THEN
  58.            QUADRANT%=0
  59.        ENDIF
  60.  
  61.        CALL SETQUAD(QUADRANT,CROW,CCOL,0,0)
  62.  
  63.        ULR%=CROW%-4
  64.        ULC%=CCOL%-12
  65.        LRR%=ULR%+9
  66.        LRC%=ULC%+21
  67.  
  68. 'Create Window for Calendar
  69. CALENDAR.GO1:
  70.        FRAME%=4
  71.        LABEL$=""
  72.        CALL MAKEWIND(ULR%,ULC%,LRR%,LRC%,FRAME%,FORE%,BACK%,GROW%,SHADOW%,LABEL$)
  73.  
  74.        GOSUB CALENDAR.DISPCAL
  75.  
  76.        EXIT SUB
  77.  
  78. '
  79. CALENDAR.DISPCAL:
  80.        GOSUB CALENDAR.NUMDAYS
  81.        FLEAP%=0
  82.        IF YEAR% MOD 400=0 THEN
  83.            GOTO CALENDAR.LEAP
  84.        ENDIF
  85.  
  86.        IF YEAR% MOD 100=0 THEN
  87.            GOTO CALENDAR.NOLEAP
  88.        ENDIF
  89.  
  90.        IF YEAR% MOD 4<>0 THEN
  91.            GOTO CALENDAR.NOLEAP
  92.        ENDIF
  93.  
  94. CALENDAR.LEAP:
  95.        FLEAP%=1
  96.  
  97.        IF ND!=28 THEN
  98.            ND!=29
  99.        ENDIF
  100.  
  101. '
  102. CALENDAR.NOLEAP:
  103.        YEAR!=YEAR%
  104.        Y1!=365*YEAR!+INT((YEAR!-1)/4)
  105.        Y2!=INT(.75*(INT((YEAR!-1)/100)+1))
  106.        YDAYS!=Y1!-Y2!
  107.        MDAYS!=0
  108.  
  109.        FOR I%=1 TO MNUM%-1
  110.            MDAYS!=MDAYS!+VAL(LKUP$(I%,2))
  111.        NEXT
  112.  
  113.        DAYS!=YDAYS!+MDAYS!+1
  114.  
  115.        IF FLEAP%=1 AND MONTH%>2 THEN
  116.            DAYS!=DAYS!+1
  117.        ENDIF
  118.  
  119.        DW!=DAYS!+INT(-DAYS!/7)*7+6
  120.  
  121.        MSG$=STRING$((LRC%-ULC%)," ")
  122.        ATTR%=(BACK% AND 7) * 16 + FORE%
  123.        COL%=ULC%
  124.        PAGE%=0
  125.  
  126.        FOR I%=(ULR%+4) TO LRR%
  127.           CALL FASTPRT(MSG$,I%,COL%,ATTR%)
  128.        NEXT
  129.  
  130.        COLOR FORE%,BACK%
  131.        LOCATE ULR%,ULC%
  132.        PRINT " ";LKUP$(MONTH%,1);
  133.        PRINT STRING$(((LRC%-ULC%)-LEN(LKUP$(MONTH%,1))-6)," ");
  134.        PRINT YEAR!;
  135.        LOCATE ULR%+1,ULC%
  136.        PRINT STRING$(LRC%-ULC%+1,205)
  137.        LOCATE ULR%+2,ULC%+1
  138.        PRINT"S  M  T  W  T  F  S"
  139.        CS!=1
  140.  
  141.        FOR R%=ULR%+4 TO ULR%+10
  142.            C1!=0
  143.            FOR C%=ULC%+1 TO ULC%+19 STEP 3
  144.                C1!=C1!+1
  145.                CD!=CS!-DW!
  146.  
  147.                IF CD!<1 OR CD!>ND! THEN
  148.                   GOTO CALENDAR.LAST
  149.                ENDIF
  150.  
  151.                CD$=STR$(CD!)
  152.                CD$=RIGHT$(CD$,LEN(CD$)-1)
  153.                ATTR%=(BACK% AND 7)*16 + FORE%
  154.                PAGE%=0
  155.                CALL FASTPRT(CD$,R%,C%,ATTR%)
  156. CALENDAR.LAST:
  157.                CS!=CS!+1
  158.            NEXT
  159.        NEXT
  160.        RETURN
  161.  
  162. '
  163. 'DETERMINE NUMBER OF DAYS IN MONTH%
  164. CALENDAR.NUMDAYS:
  165.        MNUM%=MONTH%
  166.        ND!=VAL(LKUP$(MONTH%,2))
  167.        RETURN
  168.  
  169. '
  170. CALENDAR.GETORD:
  171.        QUADRANT$=LTRIM$(QUADRANT$)
  172.        QUADRANT$=RTRIM$(QUADRANT$)
  173.  
  174.        COLON.LOC=INSTR(QUADRANT$,":")
  175.  
  176.        IF COLON.LOC=1 THEN
  177.            QUADRANT$="01"+QUADRANT$
  178.            COLON.LOC=3
  179.        ENDIF
  180.  
  181.        ULR%=VAL(LEFT$(QUADRANT$,COLON.LOC-1))
  182.  
  183.        IF (ULR%<1) OR (ULR%>24) THEN
  184.           ULR%=2
  185.        ENDIF
  186.  
  187.        IF COLON.LOC=LEN(QUADRANT$) THEN
  188.           QUADRANT$=QUADRANT$+"00"
  189.        ENDIF
  190.  
  191.        ULC%=VAL(MID$(QUADRANT$,COLON.LOC+1))
  192.        IF (ULC%<1) OR (ULC%>80) THEN
  193.            GOSUB CALENDAR.CENTER.ON.THE.LINE
  194.        ENDIF
  195.  
  196.        QUADRANT.ROW$=STR$(ULR%)
  197.        QUADRANT$="0"+RIGHT$(QUADRANT.ROW$,LEN(QUADRANT.ROW$)-1)+":"
  198.        QUADRANT.COL$=STR$(ULC%)
  199.        QUADRANT$=QUADRANT$+"0"+RIGHT$(QUADRANT.COL$,LEN(QUADRANT.COL$)-1)
  200.  
  201.        LRR%=ULR%+9
  202.        LRC%=ULC%+21
  203.        RETURN
  204.  
  205. CALENDAR.CENTER.ON.THE.LINE:
  206.        TEMP.ULC=40-(20/2)
  207.        IF (ULC<2) THEN
  208.           TEMP.ULC=2
  209.        ENDIF
  210.  
  211.        ULC=TEMP.ULC
  212.  
  213.        RETURN
  214.  
  215. '
  216. CALENDAR.DONE:
  217.        EXIT SUB
  218. END SUB
  219.