Category : Files from Magazines
Archive   : VOL10N18.ZIP
Filename : POPDEM.PRG

 
Output of file : POPDEM.PRG contained in archive : VOL10N18.ZIP
***********************************************************************
* POPDEM.PRG Clipper 5.01
* Demonstrate usage of PopCal for Clipper
***********************************************************************
SET ECHO OFF
SET TALK OFF
SETBLINK(.F.)
oldcolor = SETCOLOR("W+/B")
CLEAR screen
@ 1,1 CLEAR TO 15,78 && Clear the area
@ 1,1 TO 15,78
oldcolor = SETCOLOR("G+/B")
@ 1,30 SAY "XYZ Travel Agency"
@ 3,4 SAY "Prefix:"
@ 4,4 SAY " Last:"
@ 5,4 SAY " First:"
@ 6,4 SAY "Middle:"
@ 7,4 SAY "Suffix:"
@ 9,3 SAY "Address:"
@ 10,4 SAY " :"
@ 11,4 SAY " :"
@ 12,4 SAY " City:"
@ 13,4 SAY " State:"
DO Inquiry && Sample date field usage with
&& pop-up calendar
RELEASE ALL
CLEAR ALL
RETURN

***********************************************************************
* PROCEDURE Inquiry
* Demonstrate use of PopDate, which is called from PopCal
***********************************************************************
PROCEDURE Inquiry
@ 3, 12 CLEAR TO 13,60 && Clear the area
@ 3, 12 TO 13,60 && Box the area
@ 3, 32 SAY "Inquiry"
@ 5, 19 SAY "Destination:"
@ 7, 13 SAY "Date of Departure:"
@ 8, 16 SAY "Date of Return:"
@ 10, 16 SAY "Number of days:"
@ 12, 16 SAY "Enter Departure date, press F2 for calendar"
STORE PAD("Hawaii",25) TO m->dest
STORE DATE() TO m->depdate
STORE DATE()+1 TO m->retdate

SET KEY -1 TO POPCAL
DO WHILE .T.
oldcolor = SETCOLOR(",N/W")
@ 5,32 GET m->dest
@ 7,32 GET m->depdate ;
VALID DateCheck(1, m->depdate, m->retdate)
@ 8,32 GET m->retdate ;
VALID DateCheck(2, m->depdate, m->retdate)
READ
SETCOLOR(oldcolor)
@ 10,32 SAY (m->retdate - m->depdate)+1 PICTURE [999]
IF READKEY()==268 .OR. READKEY()==12 && Escape cancels
EXIT
ENDIF
ENDDO

SET KEY -1 TO && Restore F2
RETURN

*******************************************************************
* FUNCTION DateCheck
* Simple validation for departure and return dates
*******************************************************************
FUNCTION DateCheck
PARAMETERS dnum, ddate, rdate

DO CASE
CASE dnum == 1 && Validating the departure date
*
* --- Can't be before today or empty
*
IF ddate < DATE() .OR. EMPTY(ddate)
TONE(100,3)
RETURN .F.
ENDIF
CASE dnum == 2 && Validating the return date
*
* --- Can't be before departure date or empty
*
IF rdate < ddate .OR. EMPTY(rdate)
TONE(100,3)
RETURN .F.
ENDIF
OTHERWISE
ENDCASE
RETURN .T.

*******************************************************************************
* Program Name...: POPCAL.PRG
* Description....: A Routine to pop up a calender for choosing dates
* Author.........: F. Martin Richardson, Jr.
* Usage..........: SET KEY TO POPCAL
* Notes..........: As this is meant to be executed with the SET KEY command,
* it expects three parameters:
* P - Calling Proc. Name
* L - Calling Proc. Line No.
* V - Current Variable (the only one it uses)
*
* The calendar will only pop up if you are currently editing a DATE typed
* variable. The default date will be the one currently being edited, or
* the current date if that date is invalid or the variable is empty.
*
*******************************************************************************
PROCEDURE popcal

PARAMETERS p, l, v

PRIVATE up_arrow, down_arrow, right_arrow, left_arrow, pgup, pgdn
PRIVATE ctrl_pgup, ctrl_pgdn, box2, inp, cdate

IF TYPE( v ) <> 'D' && Make sure it is a DATE variable
RETURN
ENDIF

* Keyboard Scan Codes
up_arrow = 5
down_arrow = 24
right_arrow = 4
left_arrow = 19
pgup = 18
pgdn = 3
ctrl_pgup = 31
ctrl_pgdn = 30
shift_left = 52
shift_right = 54
shift_up = 56
shift_down = 50

box2 = 'ÉÍ»º¼ÍȺ '

* or BOX2 = chr(201) + chr(205) + chr(187) + chr(186) + chr(188) + chr(205)
* BOX2 = BOX2 + chr(200) + chr(32)

* IF !FILE( 'cal.cfg' )
lcalrow = 0
lcalcol = 50
* SAVE ALL LIKE lcal* TO cal.cfg
* ELSE
* RESTORE FROM cal.cfg ADDITIVE
* ENDIF

SET CURSOR OFF

* inverse = 'n/w'

inverse = 'W+/GR'

SAVE SCREEN TO lpopscreen

* oldcolor = setcolor( 'w+/rb' )

oldcolor = setcolor( 'W+/BG' )

trow = 5 + lcalrow
tcol = 2 + lcalcol
IF EMPTY( &v )
cdate = DATE()
ELSE
cdate = &v
ENDIF

drawcal( lcalrow, lcalcol )

DO WHILE .T.
inp = INKEY(0)
DO CASE
CASE inp = 27 .OR. inp = 13
EXIT

CASE inp = shift_up .AND. lcalrow > 0 && Shift Up-Arrow
ltempcal = savescreen( lcalrow, lcalcol, lcalrow+16, lcalcol+23 )
lcalrow = lcalrow - 1
trow = 5 + lcalrow
RESTORE SCREEN FROM lpopscreen
WINDOW( lcalrow, lcalcol, 17, 24, "GR+/B", box2, .T. )
restscreen( lcalrow, lcalcol, lcalrow+16, lcalcol+23, ltempcal )

CASE inp = shift_left .AND. lcalcol > 1 && Shift Left-Arrow
ltempcal = savescreen( lcalrow, lcalcol, lcalrow+16, lcalcol+23 )
lcalcol = lcalcol - 1
tcol = 2 + lcalcol
RESTORE SCREEN FROM lpopscreen
WINDOW( lcalrow, lcalcol, 17, 24, "GR+/B", box2, .T. )
restscreen( lcalrow, lcalcol, lcalrow+16, lcalcol+23, ltempcal )

CASE inp = shift_down .AND. lcalrow < 8 && Shift Down-Arrow
ltempcal = savescreen( lcalrow, lcalcol, lcalrow+16, lcalcol+23 )
lcalrow = lcalrow + 1
trow = 5 + lcalrow
RESTORE SCREEN FROM lpopscreen
WINDOW( lcalrow, lcalcol, 17, 24, "GR+/B", box2, .T. )
restscreen( lcalrow, lcalcol, lcalrow+16, lcalcol+23, ltempcal )

CASE inp = shift_right .AND. lcalcol < 55 && Shift Right-Arrow
ltempcal = savescreen( lcalrow, lcalcol, lcalrow+16, lcalcol+23 )
lcalcol = lcalcol + 1
tcol = 2 + lcalcol
RESTORE SCREEN FROM lpopscreen
WINDOW( lcalrow, lcalcol, 17, 24, "GR+/B", box2, .T. )
restscreen( lcalrow, lcalcol, lcalrow+16, lcalcol+23, ltempcal )

CASE inp = up_arrow
restdate( cdate )
lmonth = MONTH(cdate)
cdate = cdate - 7
IF MONTH(cdate) <> lmonth
showdates( cdate )
ELSE
currdate( cdate )
ENDIF

CASE inp = down_arrow
restdate( cdate )
lmonth = MONTH(cdate)
cdate = cdate + 7
IF MONTH(cdate) <> lmonth
showdates( cdate )
ELSE
currdate( cdate )
ENDIF

CASE inp = left_arrow
restdate( cdate )
lmonth = MONTH(cdate)
cdate = cdate - 1
IF MONTH(cdate) <> lmonth
showdates( cdate )
ELSE
currdate( cdate )
ENDIF

CASE inp = right_arrow
restdate( cdate )
lmonth = MONTH(cdate)
cdate = cdate + 1
IF MONTH(cdate) <> lmonth
showdates( cdate )
ELSE
currdate( cdate )
ENDIF

CASE inp = pgup
lmonth = MONTH( cdate ) - 1
IF lmonth < 1
lmonth = 12
ENDIF
cdate = cdate - 30
DO WHILE lmonth < MONTH(cdate)
cdate = cdate - 1
ENDDO
DO WHILE lmonth > MONTH(cdate)
cdate = cdate + 1
ENDDO
showdates( cdate )

CASE inp = pgdn
lmonth = MONTH( cdate ) + 1
IF lmonth > 12
lmonth = 1
ENDIF
cdate = cdate + 30
DO WHILE lmonth < MONTH(cdate)
cdate = cdate - 1
ENDDO
DO WHILE lmonth > MONTH(cdate)
cdate = cdate + 1
ENDDO
showdates( cdate )

CASE inp = ctrl_pgup
lday = DAY(cdate)
cdate = cdate - 365
IF lday <> DAY(cdate)
cdate = cdate - 1
ENDIF
showdates( cdate )

CASE inp = ctrl_pgdn
lday = DAY(cdate)
cdate = cdate + 365
IF lday <> DAY(cdate)
cdate = cdate + 1
ENDIF
showdates( cdate )

ENDCASE
ENDDO

RESTORE SCREEN FROM lpopscreen
IF LASTKEY() <> 27
&v = cdate
IF &v <> cdate
REPLACE &v WITH cdate
ENDIF
ENDIF
setcolor( oldcolor )
SET CURSOR ON

* Store the current Calendar Window screen coordinates
* SAVE ALL LIKE lcal* TO cal.cfg
RETURN

*******************************************************************************
* FUNCTION to draw the calendar window on the screen
*******************************************************************************
FUNCTION drawcal
PARAMETERS lcalrow, lcalcol
* WINDOW( lcalrow, lcalcol, 17, 24, setcolor(), box2, .T. )
WINDOW( lcalrow, lcalcol, 17, 24, "GR+/B", box2, .T. )

oldcolor = SETCOLOR("R+/B")
@ lcalrow, lcalcol+6 SAY "[CALENDAR]"
SETCOLOR(oldcolor)

* @ lcalrow+2, lcalcol SAY 'ÇÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄĶ'
@ lcalrow+2, lcalcol+1 SAY 'ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ'

@ lcalrow+3, lcalcol+1 SAY ' Su Mo Tu We Th Fr Sa '

* @ lcalrow+4, lcalcol SAY 'ÇÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄĶ'
@ lcalrow+4, lcalcol+1 SAY 'ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ'

showdates( cdate )
RETURN ''

*******************************************************************************
* FUNCTION to center a on row between and
*
* SYNTAX: CENTERAT( row, col1, col2, string )
*
* PARAMETERS: row Row to center on
* coll Leftmost column to center between
* colr Rightmost column to center between
* string String to center between and
*
* RETURNS: NIL
*
* NOTES: If the difference between and is less than the length
* of , then the function defaults to printing on
* row at column .
*******************************************************************************
FUNCTION centerat
PARAMETERS ROW, coll, colr, string
IF colr-coll <= LEN(string)
@ ROW, coll SAY string
ELSE
@ ROW, coll + ((colr-coll) / 2) - (LEN(string)/2) SAY string
ENDIF
RETURN ''

*******************************************************************************
* FUNCTION to display the days of the current months within the calendar
* window
*******************************************************************************
FUNCTION showdates
PARAMETERS cdate
PRIVATE trow, tcol, tdate
@ lcalrow+5, lcalcol+1 CLEAR TO lcalrow+15, lcalcol+22

tdate = cdate - (DAY(cdate)-1)
oldcolor = SETCOLOR("BG+/BG")
@ lcalrow+1, lcalcol+1 SAY center_pad( CMONTH(tdate) + ' ' + ALLTRIM(STR(YEAR(tdate))), ' ', 22 )
SETCOLOR(oldcolor)

trow = lcalrow+5
tcol = lcalcol+2
DO WHILE MONTH(tdate) = MONTH(cdate)
@ trow, tcol + (DOW(tdate)-1)*3 SAY DAY(tdate) PICTURE '99'
tdate = tdate + 1
IF DOW(tdate) = 1
trow = trow + 2
ENDIF
ENDDO
currdate( cdate )
RETURN ''

*******************************************************************************
* FUNCTION to highlight the current date
*******************************************************************************
FUNCTION currdate
PARAMETERS cdate
PRIVATE oldcolor
oldcolor = setcolor( inverse )
fday = DOW(cdate - (DAY(cdate)-1))
trow = INT((DAY(cdate)-1)/7+1)
@ (trow + IF( DOW(cdate) < fday, 1, 0)) *2+6 + (lcalrow-3), tcol+(DOW(cdate)-1)*3 SAY DAY(cdate) PICTURE '99'
setcolor( oldcolor )
RETURN ''

*******************************************************************************
* FUNCTION to un-highlight a prior current date
*******************************************************************************
FUNCTION restdate
PARAMETERS cdate
fday = DOW(cdate - (DAY(cdate)-1))
trow = INT((DAY(cdate)-1)/7+1)
@ (trow + IF( DOW(cdate) < fday, 1, 0)) *2+6 + (lcalrow-3), tcol+(DOW(cdate)-1)*3 SAY DAY(cdate) PICTURE '99'
RETURN ''

********************************************************************************
* FUNCTION to draw a window on the screen with optional shadow
*
* SYNTAX: WINDOW( row, col, rows, cols [, colr [, boxtype [, shad]]] )
*
* PARAMETERS: row Top left row of window
* col Top left column of window
* rows Number of rows
* cols Number of columns
* [colr] Color of border and background (def=current color)
* [boxtype] BOX string (def=single line)
* [shad] .T. for shadow, .F. for no shadow (def=.F.)
*
* RETURNS: NIL
*
* NOTES: You must specify COLR if you specify BOXTYPE and you must specify
* BOXTYPE if you specify SHAD!
********************************************************************************
FUNCTION WINDOW
PARAMETERS row,col,rows,cols,colr,boxtype,shadow
PRIVATE temp

* Set Defaults
IF pcount() < 5
colr = setcolor()
ENDIF
IF pcount() < 6
boxtype = "ÚÄ¿³ÙÄÀ³ "
ENDIF
IF pcount() < 7
SHADOW = .F.
ENDIF

temp = setcolor( colr ) && Preserve current colors

* Expand line boxes by 1 space for appearance
IF LEFT(boxtype, 1) = 'Ú' .OR. LEFT(boxtype, 1) = 'É' .OR. LEFT(boxtype, 1) = 'Õ' .OR. LEFT(boxtype, 1) = 'Ö'
offset = 1
ELSE
offset = 0
ENDIF

IF SHADOW
setcolor( 'n/n' )
@ ROW+1, COL+2-offset CLEAR TO ROW+rows, COL+cols+2
setcolor( colr )
ENDIF

* Again expand line boxes by 1 space for appearance
IF LEFT(boxtype, 1) = 'Ú' .OR. LEFT(boxtype, 1) = 'É' .OR. LEFT(boxtype, 1) = 'Õ' .OR. LEFT(boxtype, 1) = 'Ö'
@ ROW, COL-1, ROW+rows-1, COL+cols BOX SPACE(9)
ENDIF

@ ROW, COL, ROW+rows-1, COL+cols-1 BOX boxtype

SET COLOR TO &temp && Restore old color
RETURN(.T.)

********************************************************************************
* FUNCTION to center with padded to make LEN() =
*
* SYNTAX: CENTER_PAD( string, char, len )
*
* PARAMETERS: string String to center
* char Characters to pad on either side with
* len New length for
*
* RETURNS: centered to length , padded with
*
* NOTES: If is less than the length of , the function will
* default to the original .
********************************************************************************
FUNCTION center_pad
PARAMETERS string, char, num
PRIVATE rside, lside
IF num <= LEN( string )
RETURN( string )
ENDIF
rside = num - LEN( string )
lside = INT( rside / 2 )
rside = rside - lside
string = REPLICATE( char, lside ) + string + REPLICATE( char, rside )
RETURN( string )
*: EOF: POPUPCAL.PRG


  3 Responses to “Category : Files from Magazines
Archive   : VOL10N18.ZIP
Filename : POPDEM.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/