$CPU 8086          ' make compatible with XT systems
$LIB ALL OFF       ' turn off all PowerBASIC libraries
$ERROR ALL OFF     ' turn off all PowerBASIC error checking
$OPTIMIZE SIZE     ' optimize for smaller code
 $COMPILE UNIT      ' compile to a UNIT (.PBU)
'$COMPILE EXE       ' compile to a UNIT (.PBU)

DEFINT A-Z         ' Required for all numeric functions, forces PB to not
                   ' include floating point in UNIT (makes it smaller)
'/*------------------------------------------------------------------*/
DECLARE FUNCTION RATTR(ATTR) AS INTEGER
DECLARE SUB SAY(BYVAL Row AS INTEGER, BYVAL Col AS INTEGER, BYVAL Text AS STRING, BYVAL Attr AS INTEGER)
DECLARE FUNCTION GETKEY() AS STRING
DECLARE FUNCTION GETSCREEN() AS STRING
DECLARE SUB PUTSCREEN(BYVAL X AS STRING)
DECLARE SUB TBOX(BYVAL ROW,BYVAL COL,BYVAL ROWS,BYVAL COLS,BYVAL ATTR,BYVAL OPT,BYVAL SHAD)
'/*------------------------------------------------------------------*/
$CODE SEG "MLIB4"
'/*------------------------------------------------------------------*/
' CBOX ROW,COL,ATTR,BTYPE,D$
'     Calendar BOX.
'     Displays a scrollable calendar.
'     ROW   = Start row.  If 0, row centering is used.
'     COL   = Start column.  If 0, column centering is used.
'     ATTR  = Box Color.  If 0 then default scheme is used.
'     BTYPE = Box type.  See TBOX for types.  If 0 then 1 is used.
'     D$    = Date string in format "ccyymmdd".
'             If D$ is null (D$ = "") then the system date is used.
'     EXAMPLE:  CBOX 0,0,31,1,"19980805"
'               CBOX 0,0,0,0,""
'/*------------------------------------------------------------------*/
   SUB CBOX(ROW,COL,ATTR,BTYPE,D$) PUBLIC
     HSCREEN$ = GETSCREEN
'/*  --- Center Box? ---
     IF ROW = 0 THEN
       ROW = 12 - (9/2)
     END IF
     IF COL = 0 THEN
       COL = 40 - (24/2)
     END IF
'/*  --- Default Box Type? ---
     IF BTYPE = 0 THEN BTYPE = 1
'/*  --- Default Colors? ---
     IF ATTR = 0 THEN
       NATTR = 11            :'/*Color of Numbers
       BATTR = 12            :'/*Color of Box
       MATTR = 14            :'/*Color of Month/Year
       DATTR = 13            :'/*Color of Day Header
       HATTR = 10
     ELSE
       NATTR = ATTR
       BATTR = ATTR
       MATTR = ATTR
       DATTR = ATTR
       HATTR = RATTR(ATTR)
     END IF
     cboxrestart1:
     IF D$ = "" THEN
       J$ = MID$(DATE$,1,2)         :'/*Month
       I$ = MID$(DATE$,7,4)         :'/*Year
       DD$= MID$(DATE$,4,2)         :'/*Day
     ELSE
       J$ = MID$(D$,5,2)
       I$ = MID$(D$,1,4)
       DD$= MID$(D$,7,2)
     END IF
     R = 0
     J = VAL(J$)
     JH = J
     I = VAL(I$)        :'/*CCYY
     IH = I
     cboxrestart:
     N = 0
     N1 = 0
     N2 = 0
     N3 = 0
     J1 = 0
     '/*J = 08
     '/*I = 1995
     K = 1
     GOSUB C1000
     N2 = N
     GOSUB C2000
     N1 = N
     J1 = J
     J = J + 1
     IF J > 13 THEN N3 = 31 ELSE GOSUB C2000
     N3 = N - N1
     N$ = MID$("JanFebMarAprMayJunJulAugSepOctNovDec",3*J1-2,3)
     M$  = "*@#<&"
     TBOX ROW,COL,9,24,BATTR,BTYPE,1
     SAY ROW,COL+8,N$+STR$(I),MATTR
       SAY ROW+1,COL+2," S  M  T  W  T  F  S",DATTR
       L = 0
       Z(R+1) = 0
     FOR I = 1 TO 6
       XP$ = ""
       FOR J = 1 TO 7
         IF (J<N2+1) AND (I=1) OR (L>=N3) THEN
            XP$ = XP$ + "    "
         ELSE
           L = L + 1
           L$ = "  " + STR$(L)
           IF L = Z(K) THEN
             XP$ = XP$ + RIGHT$(L$+MID$(M$,K,1),4)
             K = K + 1
           ELSE
             XP$ = XP$ + RIGHT$(L$+"  ",4)
           END IF
         END IF
         XP$ = LEFT$(XP$,LEN(XP$)-1)
       NEXT J
       XP$ = " " + XP$
       SAY ROW+1+I,COL+1,XP$,NATTR
       S = INSTR(1,XP$,STR$(VAL(DD$)))
       IF S > 0 THEN
         T$ = MID$(XP$,S,3)
         IF VAL(T$) = VAL(DD$) THEN SAY ROW+1+I,COL+1+S,TRIM$(STR$(VAL(DD$))),HATTR
         T$ = ""
       END IF
'/*    IF S > SP THEN SAY ROW+1+I,COL+1+S,TRIM$(STR$(VAL(DD$))),HATTR
       SP = S + 1
     NEXT I
     Y$ = GETKEY
     IF Y$ = CHR$(0,81) THEN IH = IH - 1
     IF Y$ = CHR$(0,73) THEN IH = IH + 1
     IF Y$ = CHR$(0,80) THEN
       JH = JH - 1
       IF JH < 1 THEN
         JH = 12
         IH = IH - 1
       END IF
     END IF
     IF Y$ = CHR$(0,72) THEN
       JH = JH + 1
       IF JH > 12 THEN
         JH = 1
         IH = IH + 1
       END IF
     END IF
     I = IH
     J = JH
   IF Y$ = CHR$(27) THEN GOTO eexitcbox
   IF Y$ = CHR$(0,71) THEN GOTO cboxrestart1
   GOTO cboxrestart
'/*-----------------------------------------------------------------
   C1000:
     IF J > 2 THEN
       M8 = J - 2
       Y8 = I
     ELSE
       M8 = J + 10
       Y8 = I - 1
     END IF
     C8 = INT(Y8/100)
     D8 = Y8-100*C8
     N = INT((13*M8-1)/5)+K+D8+INT(D8/4)+INT(C8/4)-C8-C8+77
     N = N - 7 * INT(N/7)
   RETURN
'/*-----------------------------------------------------------------
   C2000:
     N = INT(3055*(J+2)/100)-91
     GOSUB C3000
     IF J > 2 THEN N = N - 2 + L
     N = N + K
   RETURN
'/*-----------------------------------------------------------------
   C3000:
     L = 0
     IF I = 4*INT(I/4) THEN L = 1
     IF I = 100*INT(I/100) THEN L = 0
     IF I = 400*INT(I/400) THEN L = 1
   RETURN
'/*------------------------------------------------------------------*/
   eexitcbox:
   PUTSCREEN HSCREEN$
 END SUB
'/*------------------------------------------------------------------*/
'  $INCLUDE "C:\CODE\MLIB\MLIB.INC"
'  SAY 1,1,STRING$(2000,"±"),15
'  CBOX 1,1,0,0,""