Category : Dbase (Clipper, FoxBase, etc) Languages Source Code
Archive   : NN0505.ZIP
Filename : CALENDAR.PRG

 
Output of file : CALENDAR.PRG contained in archive : NN0505.ZIP
//
// Function : CALENDAR
// Author : Thomas M. Wilson
// Version : Clipper 5.0
// Compile : Clipper Calendar /n /w /l
//
// Copyright (c) 1990 Thomas M. Wilson
// Placed in Public Domain.
//


FUNCTION Calendar()
LOCAL array[31], sysdate := DATE(), first, x, today, i, j
LOCAL day, title, date, k, placehere

SETMODE(43, 80) // Normally you wouldn't put the next few
SETCOLOR("n/bg") // lines here.
CLS

SET(_SET_CURSOR, 0)
placehere = {|day| 10 + (DOW(day) * 7)} // Code Block
SETCOLOR("n+/bg")
@ 9,15,29,66 BOX [ÜÜÜ ßßß ]
SETCOLOR("n+/w")
@ 10,15,28,66 BOX [Ý ÞÞÞ ÝÝ ]
SETCOLOR("n+/b")
@ 10,15 SAY [Ý]
@ 10,66 SAY [Þ]
SETCOLOR("bg/b")
Window_title([CALENDAR], 10, 16, 65)

// Do until escape pressed
DO WHILE NEXTKEY() <> 27

first := FOTM(sysdate) // Assign first of the month
x := DOW(first) // Day of the week for first
today := first // Day counter
SETCOLOR("n/w")
@ 14,16 SAY [ S M T W T F S]
@ 15,16 SAY [ÚÄÄÄÄÄÄÂÄÄÄÄÄÄÂÄÄÄÄÄÄÂÄÄÄÄÄÄÂÄÄÄÄÄÄÂÄÄÄÄÄÄÂÄÄÄÄÄÄ¿]
@ 16,16 SAY [³ ³ ³ ³ ³ ³ ³ ³]
@ 17,16 SAY [ÃÄÄÄÄÄÄÅÄÄÄÄÄÄÅÄÄÄÄÄÄÅÄÄÄÄÄÄÅÄÄÄÄÄÄÅÄÄÄÄÄÄÅÄÄÄÄÄÄ´]
@ 18,16 SAY [³ ³ ³ ³ ³ ³ ³ ³]
@ 19,16 SAY [ÃÄÄÄÄÄÄÅÄÄÄÄÄÄÅÄÄÄÄÄÄÅÄÄÄÄÄÄÅÄÄÄÄÄÄÅÄÄÄÄÄÄÅÄÄÄÄÄÄ´]
@ 20,16 SAY [³ ³ ³ ³ ³ ³ ³ ³]
@ 21,16 SAY [ÃÄÄÄÄÄÄÅÄÄÄÄÄÄÅÄÄÄÄÄÄÅÄÄÄÄÄÄÅÄÄÄÄÄÄÅÄÄÄÄÄÄÅÄÄÄÄÄÄ´]
@ 22,16 SAY [³ ³ ³ ³ ³ ³ ³ ³]
@ 23,16 SAY [ÃÄÄÄÄÄÄÅÄÄÄÄÄÄÅÄÄÄÄÄÄÅÄÄÄÄÄÄÅÄÄÄÄÄÄÅÄÄÄÄÄÄÅÄÄÄÄÄÄ´]
@ 24,16 SAY [³ ³ ³ ³ ³ ³ ³ ³]
@ 25,16 SAY [ÃÄÄÄÄÄÄÅÄÄÄÄÄÄÅÄÄÄÄÄÄÅÄÄÄÄÄÄÅÄÄÄÄÄÄÅÄÄÄÄÄÄÅÄÄÄÄÄÄ´]
@ 26,16 SAY [³ ³ ³ ³ ³ ³ ³ ³]
@ 27,16 SAY [ÀÄÄÄÄÄÄÁÄÄÄÄÄÄÁÄÄÄÄÄÄÁÄÄÄÄÄÄÁÄÄÄÄÄÄÁÄÄÄÄÄÄÁÄÄÄÄÄÄÙ]
title := [] + UPPER(CMONTH(sysdate)) + [] + ;
STR(YEAR(sysdate),4)+[ ]
Window_title(title, 12, 16, 65) // Display current month & year
FOR i := 16 TO 26 STEP 2
// Display each day
FOR j := x TO 7
@ i,EVAL(placehere, today) SAY DAY(today) PICT ' 99 '
array[DAY(today)] := i // Assign row for each day
++today // Increment day
IF MONTH(today) <> MONTH(first)
EXIT // Check end of month
ENDIF
NEXT
x := 1 // Reset day of the week counter
IF MONTH(today) <> MONTH(first)
EXIT // Check end of month
ENDIF
NEXT

k := 0 // Declare k

DO WHILE ! STR(k, 2) $ ' 3,18,45,43,27'
SETCOLOR("w+/n")
@ array[DAY(sysdate)],EVAL(placehere, sysdate) SAY ;
DAY(sysdate) PICT ' 99 '

@ MAXROW(),MAXCOL() SAY "" // Some monitors won't turn cursor
k := INKEY(0) // off in 43 mode.

IF STR(k, 2) $ ' 3,18,24, 5,45,43, 4,19'
SETCOLOR("n/w")
@ array[DAY(sysdate)],EVAL(placehere, sysdate) SAY ;
DAY(sysdate) PICT ' 99 '
DO CASE
CASE k = 3 // Pgdn
sysdate := FOTM(FOTM(sysdate) + 31) + DAY(sysdate) - 1
CASE k = 18 // Pgup
sysdate := FOTM(FOTM(sysdate) - 1) + DAY(sysdate) - 1
CASE k = 24 .OR. k = 5 // Dn arrow or Up arrow
sysdate := sysdate + IF(k = 24, 7, -7)
IF MONTH(sysdate) <> MONTH(first)
EXIT
ENDIF
CASE k = 19 .OR. k = 4 // Left / Right arrows
sysdate := sysdate + IF(k = 19, -1, 1)
IF MONTH(sysdate) <> MONTH(first)
EXIT
ENDIF
CASE k = 45 // Minus sign
sysdate -= 365
CASE k = 43 // Plus sign
sysdate += 365
ENDCASE
ELSEIF k = 13 // Enter / Return

// Appointments, ToDo Lists etc.

ELSEIF k = 27 // Esc
KEYBOARD CHR(27)
ENDIF
ENDDO

ENDDO
SETCURSOR(1)
CLS
SETMODE(25, 80) // Reset monitor
RETURN (NIL)


//
// Function : FOTM()
// Syntax : FOTM( )
// Purpose : To calculate the first of a month.
//

FUNCTION FOTM( date )
RETURN (date - (DAY(date) - 1))


//
// Function : Window_title()
// Syntax : Window_title( , , , )
// Purpose : Centers an expression within passed parameters.
//

FUNCTION window_title( caption, line, l, r )
LOCAL n := ((r - l) - LEN(caption)) / 2
@ line,l SAY SPACE(r-l+1)
@ line,l+n SAY caption
RETURN (NIL)

// EOF: Calendar.prg


  3 Responses to “Category : Dbase (Clipper, FoxBase, etc) Languages Source Code
Archive   : NN0505.ZIP
Filename : CALENDAR.PRG

  1. Very nice! Thank you for this wonderful archive. I wonder why I found it only now. Long live the BBS file archives!

  2. This is so awesome! 😀 I’d be cool if you could download an entire archive of this at once, though.

  3. But one thing that puzzles me is the “mtswslnkmcjklsdlsbdmMICROSOFT” string. There is an article about it here. It is definitely worth a read: http://www.os2museum.com/wp/mtswslnk/