'===========================================================================
' Subject: VB-DOS CALENDAR                    Date: 10-27-95 (07:20)       
'  Author: Frans Hersbach                     Code: VBDOS                  
'  Origin: FidoNet QUIK_BAS Echo            Packet: VB.ABC
'===========================================================================
'FH_CLNDR.BAS  * VB-DOS required !!! *
'============  -----------------------

 TYPE VideoType
   Mode    AS INTEGER 
   Rows    AS INTEGER
   Cols    AS INTEGER
   Page    AS INTEGER
   Offs    AS INTEGER
   Segment AS INTEGER
   CRT     AS INTEGER
   Colour  AS INTEGER
   Scherm  AS INTEGER
   BlnkBit AS INTEGER
   FntBlk  AS INTEGER
 END TYPE

 TYPE RegType
   AX    AS INTEGER
   BX    AS INTEGER
   CX    AS INTEGER
   DX    AS INTEGER
   BP    AS INTEGER
   SI    AS INTEGER
   DI    AS INTEGER
   FLAGS AS INTEGER
 END TYPE

'-------------------------------------------------------

 DECLARE FUNCTION Schrikkel% (Jaar%)

 DECLARE SUB StartKalender ()
 DECLARE SUB EindeKalender ()
 DECLARE SUB DisplayScherm ()
 DECLARE SUB DisplayDagen ()

 DECLARE SUB Interrupt (IntNum AS INTEGER, InReg AS RegType, OutReg AS RegType)

 DECLARE SUB Display (Col%, Row%, Tekst$, Fore%, Back%)
 DECLARE SUB DisplayVertical (Col%, Row%, Tekst$, TxtLenStap%, Richting%, Fore%, Back%)
 DECLARE SUB Video80x30 ()
 DECLARE SUB VideoCenter (Text$, Row%, Fore%, Back%)
 DECLARE SUB VideoCLS (Kleur%)
 DECLARE SUB VideoSettings ()
 DECLARE SUB VideoScrnFill (StartRow%, StartCol%, BoxHg%, BoxBrd%, ASCIIchar%, Kleur%, Page%)

'-------------------------------------------------------

 CONST True = -1, False = 0
 CONST DagNaam = "SuMoTuWeThFrSa"
 CONST MndDagen = "31 28 31 30 31 30 31 31 30 31 30 31"

 CONST Zwart = 0, Blauw = 1, Groen = 2, Cyaan = 3, Rood = 4, Paars = 5
 CONST Bruin = 6, Grijs = 7, DonkerGrijs = 8, LichtBlauw = 9
 CONST LichtGroen = 10, LichtCyaan = 11, LichtRood = 12, LichtPaars = 13
 CONST Geel = 14, Wit = 15

 CONST ForeKleur = Geel
 CONST BackKleur = Rood
 CONST DagKleur = LichtCyaan
 CONST MndKleur = LichtGroen
 CONST WknKleur = Geel
 CONST CfrKleur = Wit

'-------------------------------------------------------

 DIM SHARED Video AS VideoType
 DIM SHARED SelectJaar AS INTEGER

'-------------------------------------------------------

 DEFINT A-Z

 StartKalender

SUB Display (Col%, Row%, Tekst$, Fore%, Back%)

 SELECT CASE Video.Scherm

   CASE 15

         Location = ((Row - 1) * (Video.Cols * 2)) + ((Col - 1) * 2)
           Colour = (Fore AND 15) + (Back AND 7) * 16 + (Fore AND 16) * 8
         DEF SEG = &HB800 ' Assume VGAcolor
         FOR Char = 1 TO LEN(Tekst$)
           POKE Location + 0, ASC(MID$(Tekst$, Char, 1))
           POKE Location + 1, Colour
           Location = Location + 2
         NEXT Char
         DEF SEG

 END SELECT

END SUB

SUB DisplayDagen ()

   WeekNr = 1
 HoriOfst = 4

   CrntDag = DAY(NOW)
 CrntMaand = MONTH(NOW)
  CrntJaar = YEAR(NOW)

 FOR Maand = 1 TO 12

  DagAantal = VAL(MID$(MndDagen, (Maand - 1) * 3 + 1, 2))
  IF Maand = 2 AND Schrikkel%(SelectJaar) = True THEN
    DagAantal = DagAantal + 1
  END IF

  DagTeller = 1
  TellerOfst = WEEKDAY(DATEVALUE("1-" + FORMAT$(Maand) + "-" + FORMAT$(SelectJaar)))
  Teller = TellerOfst

  SELECT CASE Maand
    CASE 1, 5, 9: WeekTeller = 1
  END SELECT

  FOR Dag = 1 TO DagAantal

  SELECT CASE Maand
       CASE 1 TO 4: Ofst = HoriOfst + ((WeekTeller - 1) * 3) + ((Maand - 1) * 6 + 1)
                    VertOfst = 3
       CASE 5 TO 8: Ofst = HoriOfst + ((WeekTeller - 1) * 3) + ((Maand - 1) * 6 + 1) - 104
                    VertOfst = 14
      CASE 9 TO 12: Ofst = HoriOfst + ((WeekTeller - 1) * 3) + ((Maand - 1) * 6 + 1) - 208
                    VertOfst = 25
    END SELECT
    
    Display Ofst, VertOfst, RIGHT$(" " + STR$(WeekNr), 2), WknKleur, Zwart
    Display Ofst, VertOfst + Teller, RIGHT$(" " + STR$(DagTeller), 2), CfrKleur, Zwart

    IF CrntDag = Dag AND CrntMaand = Maand AND CrntJaar = SelectJaar THEN
      Display Ofst, VertOfst + Teller, RIGHT$(" " + STR$(DagTeller), 2), CfrKleur + 16, Zwart
    END IF

    Display Ofst + 2, VertOfst + Teller, "³", Grijs, Zwart

    DagTeller = DagTeller + 1
    Teller = Teller + 1
    IF Teller > 7 THEN
     Teller = 1
     WeekNr = WeekNr + 1
     WeekTeller = WeekTeller + 1
    END IF
          
  NEXT Dag

 NEXT Maand
   
END SUB

SUB DisplayScherm ()

 CLS

 Video.Scherm = 15
 Video80x30
 VideoSettings
 
 Display 1, 1, SPACE$(Video.Cols), ForeKleur, BackKleur
 VideoCenter "Kalenderjaar: " + FORMAT$(SelectJaar), 1, ForeKleur, BackKleur

  Display 10, 2, "Jan                Feb                 Mrt                Apr", MndKleur, Zwart
 Display 10, 12, "Mei                Jun                 Jul                Aug", MndKleur, Zwart
 Display 10, 22, "Sep                Okt                 Nov                Dec", MndKleur, Zwart

 DisplayVertical 1, 4, DagNaam, 2, 1, DagKleur, Zwart
 DisplayVertical 1, 14, DagNaam, 2, 1, DagKleur, Zwart
 DisplayVertical 1, 24, DagNaam, 2, 1, DagKleur, Zwart

 Display 1, 11, STRING$(80, 196), DonkerGrijs, Zwart
 Display 1, 21, STRING$(80, 196), DonkerGrijs, Zwart

END SUB

SUB DisplayVertical (Col%, Row%, Tekst$, TxtLenStap%, Richting%, Fore%, Back%)

 Aantal = LEN(Tekst$) \ TxtLenStap

 SELECT CASE Richting
   CASE IS < 0: FOR Stukje = 0 TO Aantal - 1
                  Display Col, Row + Stukje, MID$(Tekst$, (Aantal - Stukje - 1) * TxtLenStap + 1, TxtLenStap), Fore, Back
                NEXT Stukje

   CASE IS > 0: FOR Stukje = 0 TO Aantal - 1
                  Display Col, Row + Stukje, MID$(Tekst$, Stukje * TxtLenStap + 1, TxtLenStap), Fore, Back
                NEXT Stukje
 END SELECT

 
END SUB

SUB EindeKalender ()

 VideoCLS 0
 SCREEN 0, 0, 0, 0
 COLOR 7, 0
 WHILE INKEY$ <> "": WEND
 END

END SUB

FUNCTION Schrikkel% (Jaar%)

 IF Jaar \ 4 = Jaar / 4 THEN
   Schrikkel = True
 ELSE
   Schrikkel = False
 END IF

END FUNCTION

SUB StartKalender ()
 
 IF INSTR(COMMAND$, "/?") THEN
   PRINT : PRINT "KALENDER.EXE jaartal  (tussen 1753 en 2078)": END
 END IF
 
 IF COMMAND$ <> "" THEN
   CmdJaar = VAL(COMMAND$)
   IF CmdJaar >= 1753 AND CmdJaar <= 2078 THEN
     SelectJaar = CmdJaar
   ELSE
     SelectJaar = VAL(RIGHT$(DATE$, 4))
   END IF
 ELSE
   SelectJaar = VAL(RIGHT$(DATE$, 4))
 END IF

 DisplayScherm
 DisplayDagen
 SLEEP
 EindeKalender

END SUB

SUB Video80x30 ()

 DIM CrtcData AS INTEGER, CrtcIndex AS INTEGER, CRTCreg(1 TO 16) AS INTEGER
 DIM InReg AS RegType, OutReg AS RegType, i AS INTEGER

 CRTCreg(1) = &H11:   CRTCreg(2) = &HC:   CRTCreg(3) = &H6:   CRTCreg(4) = &HD
 CRTCreg(5) = &H7:    CRTCreg(6) = &H3E:  CRTCreg(7) = &H10:  CRTCreg(8) = &HEA
 CRTCreg(9) = &H11:  CRTCreg(10) = &H8C: CRTCreg(11) = &H12: CRTCreg(12) = &HDF
 CRTCreg(13) = &H15: CRTCreg(14) = &HE7: CRTCreg(15) = &H16: CRTCreg(16) = &H6
 
 DEF SEG = &H40
 POKE &H4C, 0: POKE &H4D, &H20: POKE &H84, 29
 CrtcIndex = PEEK(&H63) + 256 * PEEK(&H64)
 CrtcData = CrtcIndex + 1
 Cli = &HCBFA: DEF SEG : CALL Absolute(VARPTR(Cli))
 FOR i = 1 TO 16 STEP 2
   OUT CrtcIndex, CRTCreg(i)
   OUT CrtcData, CRTCreg(i + 1)
 NEXT i
 OUT &H3C2, ((INP(&H3CC) AND &H33) OR &HC4)
 Sti = &HCBFB: DEF SEG : CALL Absolute(VARPTR(Sti))
 InReg.AX = &H1200
 InReg.BX = &H20
 Interrupt &H10, InReg, OutReg

END SUB

SUB VideoCenter (Text$, Row%, Fore%, Back%)

 Ofst = (Video.Cols \ 2) - LEN(Text$) \ 2
 Display Ofst, Row, Text$, Fore, Back

END SUB

SUB VideoCLS (Kleur%)

 SELECT CASE Video.Scherm
   CASE 0, 16, 17: COLOR Grijs, Kleur: CLS
        CASE ELSE: VideoScrnFill 1, 1, Video.Cols, Video.Rows, 32, Zwart, 0
 END SELECT

END SUB

SUB VideoScrnFill (StartRow, StartCol, BoxHg, BoxBrd, ASCIIchar, Kleur, Page)

 DIM InReg AS RegType, OutReg AS RegType

 LOCATE 1, 1
 InReg.AX = &H9 * 256 + ASCIIchar
 InReg.BX = Page * 256 + Kleur
 InReg.CX = BoxHg * BoxBrd
 Interrupt &H10, InReg, OutReg
 
END SUB

SUB VideoSettings ()

 DIM r AS RegType

 r.AX = &H1A00
 Interrupt &H10, r, r
 VideoSrt = VAL("&H" + RIGHT$(HEX$(r.BX), 2))
 IF VideoSrt = 0 OR VideoSrt = 255 THEN SOUND 1000, 1
 Video.CRT = VideoSrt

 r.AX = &HF00
 r.BX = 0
 r.DX = 0
 Interrupt &H10, r, r
 Video.Cols = (CLNG(r.AX) - (r.AX < 0) * 65536) \ 256

 r.AX = &H1130
 r.BX = 0
 r.DX = 0
 Interrupt &H10, r, r
 Video.Rows = r.DX + 1

 DEF SEG = 0: VidMode = PEEK(&H449): DEF SEG
 SELECT CASE VidMode
   CASE 0, 2, 7: Video.Colour = 0   'Black & White 40/80 column & monochrome
      CASE ELSE: Video.Colour = -1  'Everything else... assume color
 END SELECT

END SUB