Calendar Control in FP 2.6 code? - Level Extreme

Level Extreme platform

Subscription

Corporate profile

Products & Services

Support

Legal

Français

Calendar Control in FP 2.6 code?

Message

From

13/04/2007 16:51:57

Greg Green
Independent Developer
Lincolnton, Georgia, United States

To

13/04/2007 14:29:57

Jay Johengen
Altamahaw-Ossipee, North Carolina, United States

General information

Forum:

Visual FoxPro

Category:

Other

Title:

Re: Calendar Control in FP 2.6 code?

Environment versions

Visual FoxPro:

VFP 8 SP1

Miscellaneous

Thread ID:

01215698

Message ID:

01215828

Views:

12

Below is some old code for a calendar popup in FPD2.6:

************************************************************************************************
* Written by:  Gregory A. Green
*              980 Windmill Parkway
*              Evans, GA  30809
*              (706) 651-1640
*
* Copyright ©1999 Gregory A. Green
*
* THIS SOFTWARE IS PROVIDED "AS IS" WITHOUT EXPRESS OR IMPLIED WARRANTY. ALL
* IMPLIED WARRANTIES OF FITNESS FOR ANY PARTICULAR PURPOSE ARE HEREBY DISCLAIMED.
*
************************************************************************************************
* Displays dialog for selecting a date on a calendar
*
*FUNCTION CALENDAR
PARAMETER pdDate,pwWindow,pcTitle
	PRIVATE ALL LIKE l*
	_ReFox_ = (9876543210)
	_ReFox_ = (9876543210)
	ldSelectedDate = {  /  /    }
   ldSchdMonth = SYSDATE()
   DIMENSION ldCellDates(6,7)
	IF EMPTY(pcTitle)
		DEFINE WINDOW lwcalendar AT 0.000,0.000 SIZE 16.400,30.167 FONT "Arial", 9 STYLE "B" NOFLOAT NOCLOSE NOMINIMIZE SYSTEM COLOR RGB(,,,192,192,192)
	ELSE
		DEFINE WINDOW lwcalendar AT 0.000,0.000 SIZE 16.400,30.167 TITLE pcTitle FONT "Arial", 9 STYLE "B" NOFLOAT NOCLOSE NOMINIMIZE SYSTEM COLOR RGB(,,,192,192,192)
	ENDIF
	MOVE WINDOW lwcalendar CENTER
	ACTIVATE WINDOW lwcalendar NOSHOW
	@ 0.400,1.000 TO 12.667,28.833 PEN 1, 8 COLOR RGB(255,255,255,,,,)
	@ 0.467,1.167 TO 12.734,29.000 PATTERN 1 PEN 1, 8 COLOR RGB(,,,0,128,128)
	@ 3.000,1.833 TO 12.467,28.333 PATTERN 1 PEN 1, 8 COLOR RGB(192,192,192,192,192,192)
	@ 2.067,3.000 SAY "Su" FONT "Arial", 8 STYLE "BT" COLOR RGB(255,255,255,,,,)
	@ 2.067,6.500 SAY "Mo" FONT "Arial", 8 STYLE "BT" COLOR RGB(255,255,255,,,,)
	@ 2.067,10.000 SAY "Tu" FONT "Arial", 8 STYLE "BT" COLOR RGB(255,255,255,,,,)
	@ 2.067,13.667 SAY "We" FONT "Arial", 8 STYLE "BT" COLOR RGB(255,255,255,,,,)
	@ 2.067,17.667 SAY "Th" FONT "Arial", 8 STYLE "BT" COLOR RGB(255,255,255,,,,)
	@ 2.067,21.500 SAY "Fr" FONT "Arial", 8 STYLE "BT" COLOR RGB(255,255,255,,,,)
	@ 2.067,24.833 SAY "Sa" FONT "Arial", 8 STYLE "BT" COLOR RGB(255,255,255,,,,)
	@ 13.267,1.000 GET lnPrevMonth PICTURE "@*HN <<;<" SIZE 1.429,5.000,0.000 DEFAULT 1 FONT "Arial", 8 STYLE "B" VALID fSetMonth("Previous")
	@ 13.267,9.333 GET lnCurrent PICTURE "@*HN Current" SIZE 1.429,13.600,0.800 DEFAULT 1 FONT "Arial", 8 STYLE "B" VALID fSetMonth("Current")
	@ 13.267,20.667 GET lnNextMonth PICTURE "@*HN >;>>" SIZE 1.429,5.000,0.000 DEFAULT 1 FONT "Arial", 8 STYLE "B" VALID fSetMonth("Next")
	@ 14.600,1.000 GET lnClose PICTURE "@*HT Close" SIZE 1.429,33.600,0.000 DEFAULT 1 FONT "Arial", 8 STYLE "B"
	@ 3.200,2.333 GET lnDay1 PICTURE "@*IHN ;;;;;;" SIZE 1.400,3.333,0.333 DEFAULT 0 FONT "Arial", 9 STYLE "B" VALID fReturnDay(1,lnDay1)
	@ 4.733,2.333 GET lnDay2 PICTURE "@*IHN ;;;;;;" SIZE 1.400,3.333,0.333 DEFAULT 0 FONT "Arial", 9 STYLE "B" VALID fReturnDay(2,lnDay2)
	@ 6.267,2.333 GET lnDay3 PICTURE "@*IHN ;;;;;;" SIZE 1.400,3.333,0.333 DEFAULT 0 FONT "Arial", 9 STYLE "B" VALID fReturnDay(3,lnDay3)
	@ 7.800,2.333 GET lnDay4 PICTURE "@*IHN ;;;;;;" SIZE 1.400,3.333,0.333 DEFAULT 0 FONT "Arial", 9 STYLE "B" VALID fReturnDay(4,lnDay4)
	@ 9.333,2.333 GET lnDay5 PICTURE "@*IHN ;;;;;;" SIZE 1.400,3.333,0.333 DEFAULT 0 FONT "Arial", 9 STYLE "B" VALID fReturnDay(5,lnDay5)
	@ 10.867,2.333 GET lnDay6 PICTURE "@*IHN ;;;;;;" SIZE 1.400,3.333,0.333 DEFAULT 0 FONT "Arial", 9 STYLE "B" VALID fReturnDay(6,lnDay6)
	ACTIVATE WINDOW lwcalendar
	READ CYCLE MODAL WHEN fSetMonth("Startup")
	RELEASE WINDOW lwcalendar
RETURN ldSelectedDate


FUNCTION fReturnDay                                                  && lnDay1-6 VALID
PARAMETER pnWeek,pnDay                                               && Sets the selected date for return
	IF !EMPTY(ldCellDates(pnWeek,pnDay))
		ldSelectedDate = ldCellDates(pnWeek,pnDay)
		CLEAR READ
	ENDIF
RETURN


FUNCTION fSetMonth                                                   && lnPrevMonth,lnNextMonth,lnCurrent VALIDs
PARAMETER pcMonth                                                    && Sets the month to be displayed
	PRIVATE ALL LIKE v*
	DO CASE
		CASE pcMonth = "Previous"
			IF lnPrevMonth = 1
				ldSchdMonth = GOMONTH(ldSchdMonth,-12)
			ELSE
				ldSchdMonth = GOMONTH(ldSchdMonth,-1)
			ENDIF
		CASE pcMonth = "Current"
			ldSchdMonth = SYSDATE()
		CASE pcMonth = "Next"
			IF lnNextMonth = 1
				ldSchdMonth = GOMONTH(ldSchdMonth,1)
			ELSE
				ldSchdMonth = GOMONTH(ldSchdMonth,12)
			ENDIF
		CASE pcMonth = "Startup"
			IF EMPTY(pdDate)
				ldSchdMonth = SYSDATE()
			ELSE
				ldSchdMonth = pdDate
			ENDIF
	ENDCASE
	=fDisplayMonth(MONTH(ldSchdMonth),YEAR(ldSchdMonth))
RETURN


FUNCTION fDisplayMonth                                               && Displays the selected month
PARAMETER pnMonth,pnYear
	PRIVATE ALL LIKE v*
	@ 3.000,1.833 TO 12.467,28.333 PATTERN 1 PEN 1, 8 COLOR RGB(192,192,192,192,192,192)
	vdStartDate = CTOD(STR(pnMonth,2) + "/01/" + STR(pnYear,4))
	vcMonth = PADC(CMONTH(vdStartDate) + " " + STR(pnYear,4),16," ")
	@ 0.600,1.833 TO 1.800,28.333 PATTERN 1 PEN 1, 8 COLOR RGB(0,128,128,0,128,128)
	@ 0.667,7.000 SAY vcMonth FONT "Arial", 10 STYLE "BT" COLOR RGB(255,255,255,,,,)
	vcWeekDay = CDOW(vdStartDate)
	DO CASE                                                           && Set the beginning block to enter dates on calendar
		CASE vcWeekDay = "Sunday"
			vnStart = 1
		CASE vcWeekDay = "Monday"
			vnStart = 2
		CASE vcWeekDay = "Tuesday"
			vnStart = 3
		CASE vcWeekDay = "Wednesday"
			vnStart = 4
		CASE vcWeekDay = "Thursday"
			vnStart = 5
		CASE vcWeekDay = "Friday"
			vnStart = 6
		CASE vcWeekDay = "Saturday"
			vnStart = 7
	ENDCASE
	DO CASE                                                           && Get the number of the days in the month
	   CASE INLIST(pnMonth,1,3,5,7,8,10,12)
   	   vnNumDays = 31
	   CASE pnMonth = 2                                               && Check for leap year
   	   IF CTOD('02/28/'+STR(pnYear,4))+1 != CTOD('03/01/'+STR(pnYear,4))
      	   vnNumDays = 29
	      ELSE
   	      vnNumDays = 28
      	ENDIF
	   CASE INLIST(pnMonth,4,6,9,11)
   	   vnNumDays = 30
	ENDCASE
	vnDay = 0
	vnRow = 3.200
	vnCol = 2.333
	FOR vnWeek=1 TO 6
		FOR vnNdx=1 TO 7
			ldCellDates(vnWeek,vnNdx) = {  /  /  }
			IF vnNdx >= vnStart
				vnDay = vnDay + 1
				IF vnDay <= vnNumDays
					@ vnRow,vnCol TO vnRow+1.333,vnCol+3.333 PEN 1, 8 COLOR RGB(255,255,255,,,,)
					@ vnRow+0.067,vnCol+0.167 TO vnRow+1.400,vnCol+3.500 PEN 1, 8 COLOR RGB(128,128,128,,,,)
					vdDate = CTOD(STR(pnMonth,2) + "/" + STR(vnDay,2) + "/" + STR(pnYear,4))
					ldCellDates(vnWeek,vnNdx) = vdDate
					IF LEN(ALLTRIM(STR(vnDay))) > 1
						@ vnRow+0.267,vnCol+0.734 SAY ALLTRIM(STR(vnDay)) FONT "Arial", 8 STYLE "BT"
					ELSE
						@ vnRow+0.267,vnCol+1.334 SAY ALLTRIM(STR(vnDay)) FONT "Arial", 8 STYLE "BT"
					ENDIF
				ENDIF
			ENDIF
			vnCol = vnCol + 3.667
		ENDFOR
		vnRow = vnRow + 1.533
		vnCol = 2.333
		vnStart = 1
	ENDFOR
RETURN

Click here to load this message in the networking platform