Calendar Code 02 of 02

 BBS: Inland Empire Archive
Date: 01-08-93 (10:54)             Number: 392
From: JOE NEGRON                   Refer#: NONE
  To: AL LAWRENCE                   Recvd: NO  
Subj: Calendar Code 02 of 02         Conf: (2) Quik_Bas

'***********************************************************************
'* FUNCTION MthName$
'*
'* PURPOSE
'*    Returns then name of the month given a string in the standard date
'*    format.
'***********************************************************************
FUNCTION MthName$ (DateX$) STATIC
   MthName$ = MID$("JanFebMarAprMayJunJulAugSepOctNovDec",_
                   VAL(DateX$) * 3 - 2, 3)
END FUNCTION

'***********************************************************************
'* SUB OneMthCal
'*
'* PURPOSE
'*    Prints a one-month calendar for the given date at the current
'*    screen location.
'*
'* INTERNAL ROUTINE(S)
'*    FUNCTION Date2Day% (DateX$)
'*    FUNCTION Date2Mth% (DateX$)
'*    FUNCTION Date2Serial& (DateX$)
'*    FUNCTION Date2Year% (DateX$)
'*    FUNCTION DayOfTheWeek$ (DateX$)
'*    FUNCTION MDY2Date$ (Month%, Day%, Year%)
'*    FUNCTION MthName$ (DateX$)
'*    FUNCTION Serial2Date$ (Serial&)
'***********************************************************************
SUB OneMthCal (DateX$) STATIC
   Row% = CSRLIN
   Col% = POS(0)

   MName$ = MthName$(DateX$)
   LOCATE Row%, Col% + 12 - LEN(MName$) \ 2

   Year% = Date2Year%(DateX$)
   PRINT MName$; ","; Year%

   Month% = Date2Mth%(DateX$)
   Day% = 1
   Date1$ = MDY2Date$(Month%, Day%, Year%)
   Serial& = Date2Serial&(Date1$)
   Heading$ = " Sun Mon Tue Wed Thu Fri Sat"
   WA% = INSTR(1, Heading$, LEFT$(DayOfTheWeek$(Date1$), 3)) \ 4
   LOCATE Row% + 1, Col%
   PRINT Heading$

   RowLoc% = Row% + 2
   LOCATE RowLoc%, Col% + 4 * WA%

   DO
      PRINT USING "####"; Day%;

      IF WA% = 6 THEN
         RowLoc% = RowLoc% + 1
         LOCATE RowLoc%, Col%
      END IF

      WA% = (WA% + 1) MOD 7
      Serial& = Serial& + 1
      Day% = Date2Day%(Serial2Date$(Serial&))
   LOOP UNTIL Day% = 1
END SUB

'***********************************************************************
'* FUNCTION Serial2Date$
'*
'* PURPOSE
'*    Returns a date in the standard date format given a Julian day
'*    number.
'*
'* INTERNAL ROUTINE(S)
'*    FUNCTION MDY2Date$ (Month%, Day%, Year%)
'***********************************************************************
FUNCTION Serial2Date$ (Serial&) STATIC
   X& = 4 * Serial& - 6884477
   Y& = (X& \ 146097) * 100
   D& = (X& MOD 146097) \ 4

   X& = 4 * D& + 3
   Y& = (X& \ 1461) + Y&
   D& = (X& MOD 1461) \ 4 + 1

   X& = 5 * D& - 3
   M& = X& \ 153 + 1

   D& = (X& MOD 153) \ 5 + 1

   IF M& < 11 THEN
      Month% = M& + 2
   ELSE
      Month% = M& - 10
   END IF

   Day% = D&
   Year% = Y& + M& \ 11

   DateX$ = MDY2Date$(Month%, Day%, Year%)
   Serial2Date$ = DateX$
END FUNCTION
=============================== End code ===============================
                       <<< End part 02 of 02 >>>

                                --Joe in Bay Ridge, Brooklyn, NY--
                                      Fri  01-08-1993, 10:53

... Make it as simple as possible, but no simpler.
___
 X Blue Wave/QWK v2.12 X

--- Maximus 2.01wb
 * Origin: * BlueDog BBS * (212) 594-4425 * NYC FileBone Hub (1:278/709)