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