A configurable desktop calendar

Published on by Yousfi Benameur


this is a calendar originally downloaded from
https://www.universalthread.com/ViewPageNewDownload.aspx?ID=33853
calendar.zip
Emmanuel Galanopoulos Athens
Graphical Month Calendar
Tuesday, November 13th, 2007 at 09h52
(he agreed to this update by email)

-added capabilities below
1-standalone calendar as top level form
2-contextuel menu to set
        3-forecolors
	4-gradients backcolors (can fix random to ones in code)
	5-configurable transparency ( 170-255)
	6-replacing images buttons with labels with webding font
	7-replacing 2 contextuels menus with spinner
	8-moving by mousedown the calendar (in labels at top and bottom left)
	9-a help button
For the demo i choosen random colors.can fix some colors wanted in code...	
Of course can build a project,add a config.fpw and compile an exe.	
Note:
can use the calendar with form.shoWindow=0,1 but have not transparency.
can use the calendar with showWindow=0,1 and desktop=.t.  then have transparency.
of course can use the calendar as modal (windowtype=1-the modality is prevailing on the form.showWindow=2)and fire it as originally class from another form to return a date...


Click on code to select [then copy] -click outside to deselect


If _vfp.StartMode=0
On Shutdown Quit
Endi

_Screen.WindowState=1
Declare Integer GetWindowLong In user32;
INTEGER HWnd, Integer nIndex

Declare Integer SetWindowLong In user32;
INTEGER HWnd, Integer nIndex, Integer dwNewLong

Declare Integer SetLayeredWindowAttributes In user32;
INTEGER HWnd, Integer crKey,;
SHORT bAlpha, Integer dwFlags
Set Date SHORT

Publi yform
yform=Newobject("calendar")
yform.TitleBar=0
yform.Show
Read Events
Retu
*
Define Class calendar As Form
Top = 0
Left = 0
Height = 175
Width = 175
ShowWindow=2
Picture = ""
BorderStyle = 1
Caption = "Calendar"
FontBold = .T.
FontName = "MS Sans Serif"
TitleBar = 1
ShowTips=1
yforecolor=Rgb(0,0,0)
WindowType = 0   &&1 if want to return result
AlwaysOnTop = .T.
nmonth = .F.
nyear = .F.
nday = .F.
ddate = .F.
color_header01 ="rgb(7,95,30)"      && "RGB(120,60,10)"
color_body01 = "RGB(110,110,155)"
color_header02 = "RGB(230,140,80)"
color_line01 = "Rgb(0,0,0)"
color_body02 = "RGB(210,210,255)"
color_footer01 = "RGB(230,140,80)"
color_footer02 = "RGB(120,60,10)"
color_texthighlight01 = "RGB(220,220,255)"
color_selectionborder01 = "RGB(120,60,10)"
color_selectionfill01 = "RGB(200,160,100)"
Name = "calendar"

Add Object imgbackground As Image With ;
    Picture = "..\program files\microsoft visual foxpro 9\", ;
	Stretch = 2, ;
	Height = 175, ;
	Left = 0, ;
	Top = 0, ;
	Width = 175, ;
	Name = "ImgBackGround"

Add Object label1 As Label With ;
	FontName = "MS Sans Serif", ;
	BackStyle = 0, ;
	Caption = "Mon  Tue  Wed  Thu  Fri   Sat  Sun", ;
	Height = 17, ;
	Left = 3, ;
	Top = 37, ;
	Width = 168, ;
	ForeColor = Rgb(255,255,255), ;
	Name = "Label1"

Add Object lblmonth1 As Label With ;
	FontBold = .T., ;
	FontName = "MS Sans Serif", ;
	BackStyle = 0, ;
	Caption = "ÉáíïõÜñéïò", ;
	Height = 15, ;
	Left = 36, ;
	Top = 10, ;
	Width = 67, ;
	mousepointer=15, ;
	Name = "LblMonth1"

Add Object lblyear1 As Label With ;
	AutoSize = .T., ;
	FontBold = .T., ;
	FontName = "MS Sans Serif", ;
	BackStyle = 0, ;
	Mousepointer=15, ;
	Caption = "2006", ;
	Height = 15, ;
	Left = 104, ;
	Top = 10, ;
	Width = 30, ;
	Name = "LblYEar1"

Add Object label4 As Label With ;
	FontBold = .T., ;
	FontName = "MS Sans Serif", ;
	Alignment = 2, ;
	BackStyle = 0, ;
	Caption = "Today :", ;
	MOUSEPOINTER=15, ;
	Height = 17, ;
	Left = 27, ;
	Top = 158, ;
	Width = 57, ;
	Name = "Label4"

Add Object lbltoday1 As Label With ;
	FontName = "MS Sans Serif", ;
	Alignment = 0, ;
	BackStyle = 0, ;
	Caption = "1/1/2000", ;
	Height = 17, ;
	Left = 83, ;
	Top = 158, ;
	Width = 80, ;
	Name = "LblToday1"

Add Object shpday2 As Shape With ;
	Top = 158, ;
	Left = 2, ;
	Height = 15, ;
	Width = 25, ;
	BackStyle = 0, ;
	BorderWidth = 2, ;
	MousePointer = 15, ;
	BackColor = Rgb(200,0,0), ;
	BorderColor = Rgb(200,0,0), ;
	Name = "ShpDay2"

Add Object shpday1 As Shape With ;
	Top = 158, ;
	Left = 147, ;
	Height = 15, ;
	Width = 25, ;
	BackStyle = 1, ;
	BorderWidth = 2, ;
	DrawMode = 9, ;
	BorderColor = Rgb(200,0,0), ;
	Name = "ShpDay1"

Add Object command1 As CommandButton With ;
	Top = 9, ;
	Left = 150, ;
	Height = 16, ;
	Width = 22, ;
	fontname="webdings", ;
	Caption = "4", ;
	mousepointer=15,;
	TabStop = .F., ;
	Name = "Command1"

Add Object command2 As CommandButton With ;
	Top = 9, ;
	Left = 3, ;
	Height = 16, ;
	Width = 22, ;
	fontname="webdings", ;
	Caption = "3", ;
	mousepointer=15,;
	TabStop = .F., ;
	Name = "Command2"

Add Object btndummy As CommandButton With ;
	Top = 24, ;
	Left = 73, ;
	Height = 16, ;
	Width = 24, ;
	Caption = "0", ;
	TabStop = .F., ;
	Name = "BtnDummy"

Add Object label2 As Label With ;
	FontBold = .T., ;
	FontName = "MS Sans Serif", ;
	Alignment = 2, ;
	BackStyle = 0, ;
	Caption = "X", ;
	Height = 13, ;
	Left = 152, ;
	MousePointer = 15, ;
	Top = 159, ;
	Width = 21, ;
	ForeColor = Rgb(0,0,0), ;
	Name = "Label2"

Procedure ddate_assign
	Lparameters vNewVal
	This.ddate = m.vNewVal
	This.LockScreen=.T.

	This.nyear=Year(This.ddate)
	This.nmonth=Month(This.ddate)
	This.nday=Day(This.ddate)

	* Month , Year Update
	**********************
	This.lblmonth1.Caption=DateToMonth(This.ddate)+" "
	This.lblyear1.Caption=Str(This.nyear,4)

	This.lblmonth1.Width=This.TextWidth(This.lblmonth1.Caption)
	This.lblmonth1.Left=Int((This.Width-(This.lblmonth1.Width+This.lblyear1.Width))/2)
	This.lblyear1.Left=This.lblmonth1.Left+This.lblmonth1.Width

	* Days Update
	**********************
	nFirstDay=Dow(Date(This.nyear,This.nmonth,1),2)
	nFirstDay=Iif(nFirstDay=1,8,nFirstDay)
	nLastPrvDay=Day(Date(This.nyear,This.nmonth,1)-1) && Previous Month's Last Day
	nPrvMonth=Month(Date(This.nyear,This.nmonth,1)-1) && Previous Month
	nNextMonth=Month(Gomonth(This.ddate,+1)) && Next Month

	nLastCurDay=Day(Gomonth(Date(This.nyear,This.nmonth,1),+1)-1) && Current Month's Last Day

	* Previous Month Days
	*********************
	For N=nFirstDay-1 To 1 Step -1
		cLbl="Lbl"+Alltrim(Str(N))
		This.&cLbl..ForeColor=Rgb(100,100,100)
		This.&cLbl..Caption=Str(nLastPrvDay,2)
		This.&cLbl..nday=nLastPrvDay
		This.&cLbl..nmonth=nPrvMonth
		This.&cLbl..MousePointer=0
		nLastPrvDay=nLastPrvDay-1
	Endfor

	* Current Month Days
	**********************
	For N=nFirstDay To nFirstDay+nLastCurDay-1
		cLbl="Lbl"+Alltrim(Str(N))
		This.&cLbl..ForeColor=Thisform.yforecolor
		This.&cLbl..Caption=Str(N-nFirstDay+1,2)
		This.&cLbl..nday=N-nFirstDay+1
		This.&cLbl..nmonth=This.nmonth
		This.&cLbl..MousePointer=15
	Endfor

	* Next Month Days
	*****************
	nday=1
	For N=nFirstDay+nLastCurDay To 42
		cLbl="Lbl"+Alltrim(Str(N))
		This.&cLbl..ForeColor=Rgb(100,100,100)
		This.&cLbl..Caption=Str(nday,2)
		This.&cLbl..nday=nday
		This.&cLbl..nmonth=nNextMonth
		This.&cLbl..MousePointer=0
		nday=nday+1
	Endfor

	* Day Mark
	**********
	If Year(Date())=This.nyear And Month(Date())=This.nmonth
		cLbl="Lbl"+Alltrim(Str(nFirstDay+Day(Date())-1))
		This.shpday1.Left=This.&cLbl..Left
		This.shpday1.Top=This.&cLbl..Top
		This.shpday1.Visible=.T.
	Else
		This.shpday1.Visible=.F.
	Endif
	This.LockScreen=.F.
Endproc

Procedure monthselect
	* Months Menu
	*************
	Lparameters nmonth
	This.ddate=Date(This.nyear,nmonth,This.nday)
Endproc


Procedure yearselect
	* Months Year
	*************
	Lparameters nyear
	This.ddate=Date(nyear,This.nmonth,This.nday)
Endproc

Procedure addgradient
	* Add Gradient
	**************
	Lparameters StartColor,EndColor,nWidth,nHeight,nNull
	Local cPixelMap
	nBitDepth=24
	cPixelMap=""

	StartRed=Eval("0x"+Substr(Transform(StartColor,"@0"),9,2))
	StartGreen=Eval("0x"+Substr(Transform(StartColor,"@0"),7,2))
	StartBlue=Eval("0x"+Substr(Transform(StartColor,"@0"),5,2))

	EndRed=Eval("0x"+Substr(Transform(EndColor,"@0"),9,2))
	EndGreen=Eval("0x"+Substr(Transform(EndColor,"@0"),7,2))
	EndBlue=Eval("0x"+Substr(Transform(EndColor,"@0"),5,2))

	* Color Step
	************
	StepRed=(EndRed-StartRed)/nHeight
	StepGreen=(EndGreen-StartGreen)/nHeight
	StepBlue=(EndBlue-StartBlue)/nHeight

	For N=1 To nHeight
		nRed=StartRed+Round(StepRed*N,0)
		nRed=Iif(nRed>255,255,Iif(nRed<0,0,nRed))
		nGreen=StartGreen+Round(StepGreen*N,0)
		nGreen=Iif(nGreen>255,255,Iif(nGreen<0,0,nGreen))
		nBlue=StartBlue+Round(StepBlue*N,0)
		nBlue=Iif(nBlue>255,255,Iif(nBlue<0,0,nBlue))
		cPixelMap=cPixelMap+Replicate(Chr(nBlue)+Chr(nGreen)+Chr(nRed),nWidth)+Replicate(Chr(0),nNull)
	Endfor
	Return cPixelMap
Endproc


Procedure paintbackground
	* Paint BackGround
	*******************
	nBmpWidth=This.imgbackground.Width
	nBmpHeight=This.imgbackground.Height
	nBitDepth=24

	Do Case
		Case nBmpWidth<4
			nNull=4-nBmpWidth
		Case Mod(nBmpWidth*(nBitDepth/8),4)>0
			nNull=4-Mod(nBmpWidth*(nBitDepth/8),4)
		Otherwise
			nNull=0
	Endcase

	* BMP File Header
	*****************
	cBMPString="BM"
	nfileSize=54+((nBmpWidth*nBmpHeight*nBitDepth)/8)+2+(nNull*nBmpHeight) &&54 Header + Pixels + 2 eof + Nulls
	cFileSize=HexToStr(Right(Transform(nfileSize,"@0"),8))
	cReserved=Replicate(Chr(0),4)
	cOffset=HexToStr(Right(Transform(54,"@0"),8))
	cHeaderSize=HexToStr(Right(Transform(40,"@0"),8))
	cBmpWidth=HexToStr(Right(Transform(nBmpWidth,"@0"),8))
	cBmpHeight=HexToStr(Right(Transform(nBmpHeight,"@0"),8))
	cPlanes=HexToStr(Right(Transform(1,"@0"),4))
	cBitDepth=HexToStr(Right(Transform(nBitDepth,"@0"),4))
	cCompressType=Replicate(Chr(0),8)
	cResolution=Replicate(Chr(0),16)

	* Footer Gradient Backcolor -> White
	***************************
	cPixelMap=""
	cPixelLine=Thisform.addgradient(This.color_line01,This.color_line01,nBmpWidth,1,nNull)

	cPixelMap=cPixelMap+Thisform.addgradient(This.color_footer02,This.color_footer01,nBmpWidth,19,nNull)
	cPixelMap=cPixelMap+cPixelLine
	cPixelMap=cPixelMap+Thisform.addgradient(This.color_body01,This.color_body02,nBmpWidth,60,nNull)
	cPixelMap=cPixelMap+Thisform.addgradient(This.color_body02,This.color_body01,nBmpWidth,60,nNull)

	nLineChars=(nBmpWidth*(nBitDepth/8))+nNull
	cPixelMap=Stuff(cPixelMap,Len(cPixelMap)-(18*nLineChars),nLineChars,cPixelLine)

	cPixelMap=cPixelMap+cPixelLine
	cPixelMap=cPixelMap+Thisform.addgradient(This.color_header02,This.color_header01,nBmpWidth,35,nNull)

	* Bitmap String
	**********************
	cBMPString=cBMPString+cFileSize+cReserved+cOffset+cHeaderSize+cBmpWidth+cBmpHeight+cPlanes;
		+cBitDepth+cCompressType+cResolution+cPixelMap+Chr(0)+Chr(0)

	Thisform.imgbackground.PictureVal=cBMPString
Endproc

Procedure Deactivate
	Thisform.Release()
Endproc

Procedure Init
	With Thisform
		.AddObject("yspin1","yspin")
		With .yspin1
			.Left=.Parent.command1.Left-.Width-3
			.Top=.Parent.command1.Top-5
			.Visible=.T.
		Endwith

		.AddObject("yhelp1","yhelp")
		With .yhelp1
			.Left=Thisform.command2.Left+Thisform.command2.Width+1
			.Top=Thisform.command2.Top-5
			.Visible=.T.
		Endwith
	Endwith

	Thisform.yforec()
	nXcoord=50
	nycoord=50
	This.Top=nycoord
	This.Left=nXcoord
	* Create Day Labels
	************************
	nXLbl=0
	nYLbl=55
	nLbl=1
	For nY=1 To 6
		For nX=1 To 7
			LblName="Lbl"+Alltrim(Str(nLbl))
			This.AddObject(LblName,"Calendar_Lbl1")
			This.&LblName..Top=nYLbl
			This.&LblName..Left=nXLbl
			This.&LblName..Visible=.T.
			nXLbl=nXLbl+This.&LblName..Width
			nLbl=nLbl+1
		Endfor
		nYLbl=nYLbl+This.&LblName..Height
		nXLbl=0
	Endfor

	* Update Calendar
	************************
	This.color_header01=Eval(This.color_header01)
	This.color_header02=Eval(This.color_header02)
	This.color_body01=Eval(This.color_body01)
	This.color_body02=Eval(This.color_body02)
	This.color_footer01=Eval(This.color_footer01)
	This.color_footer02=Eval(This.color_footer02)
	This.color_line01=Eval(This.color_line01)
	This.color_texthighlight01=Eval(This.color_texthighlight01)

	This.paintbackground()
	This.shpday1.BorderColor=Eval(This.color_selectionborder01)
	This.shpday1.BackColor=Eval(This.color_selectionfill01)

	This.shpday2.BorderColor=Eval(This.color_selectionborder01)

	This.lbltoday1.Caption=Substr(Cdow(Date()),1,2)+" "+Dtoc(Date())
	This.ddate=Date()
	=Thisform.ytranspa()
	This.Visible=.T.
Endproc
Procedure ytranspa()
	Lparameters ytranspa
	If Empty(ytranspa)
		ytranspa=250
	Endi
	#Define LWA_COLORKEY 1
	#Define LWA_ALPHA 2
	#Define GWL_EXSTYLE -20
	#Define WS_EX_LAYERED 0x80000

	Local nExStyle, nRgb, nAlpha, nFlags
	nExStyle = GetWindowLong(Thisform.HWnd, GWL_EXSTYLE)
	nExStyle = Bitor(nExStyle, WS_EX_LAYERED)
	= SetWindowLong(Thisform.HWnd, GWL_EXSTYLE, nExStyle)
	= SetLayeredWindowAttributes(Thisform.HWnd, Thisform.BackColor, ytranspa,LWA_COLORKEY+LWA_ALPHA)
Endproc

Procedure lblmonth1.MouseDown
	Lparameters nButton, nShift, nXcoord, nycoord
	lnHandle = Thisform.HWnd
	param1 = 274
	param2 = 0xF012
	Declare Integer ReleaseCapture In WIN32API
	Declare Integer SendMessage In WIN32API Integer, Integer, Integer, Integer
	bb=ReleaseCapture()
	bb=SendMessage(lnHandle, param1, param2,0)
Endproc

Procedure lblyear1.MouseDown
	Lparameters nButton, nShift, nXcoord, nycoord
	Thisform.lblmonth1.MouseDown()
Endproc

Procedure label4.Click
	*thisform.yforec()
	This.Parent.ddate=Date()
	*thisform.yforec()
Endproc

Procedure command1.MouseUp
	Lparameters nButton, nShift, nXcoord, nycoord
	This.Parent.btndummy.SetFocus()
Endproc

Procedure command1.Click
	* Next Month
	********************
	This.Parent.ddate=Gomonth(This.Parent.ddate,+1)
Endproc

Procedure command2.MouseUp
	Lparameters nButton, nShift, nXcoord, nycoord
	This.Parent.btndummy.SetFocus()
Endproc

Procedure command2.Click
	* Previous Month
	********************
	This.Parent.ddate=Gomonth(This.Parent.ddate,-1)
Endproc

Procedure btndummy.Init
	This.Top=-20
Endproc

Procedure label2.Click
	* Exit
	Thisform.Release()
Endproc

Procedure Destroy
	Clea Events
Endproc

Procedure shpday2.MouseDown
	Lparameters nButton, nShift, nXcoord, nycoord

	lnHandle = Thisform.HWnd
	param1 = 274
	param2 = 0xF012
	Declare Integer ReleaseCapture In WIN32API
	Declare Integer SendMessage In WIN32API Integer, Integer, Integer, Integer
	bb=ReleaseCapture()
	bb=SendMessage(lnHandle, param1, param2,0)
Endproc

Procedure shpday2.RightClick
	Thisform.ycontext()
Endproc

Procedure shpday2.Click
	Thisform.ycontext()
Endproc

Procedure yforec
	Lparameters yindex
	If Pcount()=0
		yindex=6
	Endi
	Do Case
		Case yindex=1
			Thisform.yforecolor=0
		Case yindex=2
			Thisform.yforecolor=255
		Case yindex=3
			Thisform.yforecolor=Rgb(128,0,64)
		Case yindex=4
			Thisform.yforecolor=Rgb(255,255,255)
		Case yindex=5
			Thisform.yforecolor=Rgb(0,0,255)
		Case yindex=6
			Rand(-1)
			Thisform.yforecolor=Rgb(255*Rand(),255*Rand(),255*Rand())
	Endcase

	Try
		This.label4.Click()
	Catch
	Endtry
Endproc

Procedure ycontext()
	DoDefault()
	Define Popup raccourci  shortcut Color G/W*, B/W*,,,,W+/GR Relative From Mrow(),Mcol()
	Define Bar 1 Of raccourci Prompt "Transparency"
	Define Bar 2 Of raccourci Prompt "Random Back colors"
	Define Bar 3 Of raccourci Prompt "Forecolors"
	Define Bar 4 Of raccourci Prompt "Headers Forecolors"

	On Selection Bar 1 Of raccourci ;
		_screen.ActiveForm._4jm0ml5js ()
	On Selection Bar 2 Of raccourci ;
		_screen.ActiveForm._4jm0ml5jw ()
	On Bar 3 Of raccourci Activate Popup forecolors
	On Bar 4 Of raccourci Activate Popup headersbac


	Define Popup forecolors shortcut Relative
	Define Bar 1 Of forecolors Prompt "black"
	Define Bar 2 Of forecolors Prompt "red"
	Define Bar 3 Of forecolors Prompt "maroon"
	Define Bar 4 Of forecolors Prompt "white"
	Define Bar 5 Of forecolors Prompt "blue"
	Define Bar 6 Of forecolors Prompt "random"
	On Selection Bar 1 Of forecolors _Screen.ActiveForm.yforec (1)
	On Selection Bar 2 Of forecolors _Screen.ActiveForm.yforec (2)
	On Selection Bar 3 Of forecolors _Screen.ActiveForm.yforec (3)
	On Selection Bar 4 Of forecolors _Screen.ActiveForm.yforec (4)
	On Selection Bar 5 Of forecolors _Screen.ActiveForm.yforec (5)
	On Selection Bar 6 Of forecolors _Screen.ActiveForm.yforec (6)

	Define Popup headersbac shortcut Relative
	Define Bar 1 Of headersbac Prompt "black"
	Define Bar 2 Of headersbac Prompt "red"
	Define Bar 3 Of headersbac Prompt "white"
	Define Bar 4 Of headersbac Prompt "maroon"
	Define Bar 5 Of headersbac Prompt "random"
	On Selection Bar 1 Of headersbac _Screen.ActiveForm.SetAll("forecolor",0,"label")
	On Selection Bar 2 Of headersbac _Screen.ActiveForm.SetAll("forecolor",255,"label")
	On Selection Bar 3 Of headersbac _Screen.ActiveForm.SetAll("forecolor",Rgb(255,255,255),"label")
	On Selection Bar 4 Of headersbac _Screen.ActiveForm.SetAll("forecolor",Rgb(128,0,64),"label")
	On Selection Bar 5 Of headersbac _Screen.ActiveForm.SetAll("forecolor",Rgb(255*Rand(),255*Rand(),255*Rand()),"label")


	Activate Popup raccourci
Endproc
************************
Procedure _4jm0ml5js
	Local m.xtranspa
	m.xtranspa=Int(Val(Inputbox("Transparency:200-255","","220")))
	If !Between(m.xtranspa,170,255)
		m.xtranspa=220
	Endi
	_Screen.ActiveForm.ytranspa(m.xtranspa)
Endproc
*
Procedure _4jm0ml5jw
	DoDefault()
	Rand(-1)
	With _Screen.ActiveForm
		.color_header01=Rgb(255*Rand(),255*Rand(),255*Rand())
		.color_header02=Rgb(255*Rand(),255*Rand(),255*Rand())
		.color_body01=Rgb(255*Rand(),255*Rand(),255*Rand())
		.color_body02=Rgb(255*Rand(),255*Rand(),255*Rand())
		.color_footer01=Rgb(255*Rand(),255*Rand(),255*Rand())
		.color_footer02=Rgb(255*Rand(),255*Rand(),255*Rand())
		.color_line01=Rgb(255*Rand(),255*Rand(),255*Rand())
		.color_texthighlight01=Rgb(255*Rand(),255*Rand(),255*Rand())
		.paintbackground()
	Endwith
Endproc

Enddefine
*-- EndDefine: calendar
***********************
Define Class calendar_lbl1 As Label
Alignment = 2
BackStyle = 0
Caption = "00"
Height = 17
MousePointer = 0
Width = 25
nday = 0
nmonth = 0
yf=0
Name = "calendar_lbl1"

Procedure Click
	If This.Parent.nmonth=This.nmonth
		Messagebox(Date(This.Parent.nyear,This.Parent.nmonth,This.nday),032+4096,'',1200)
		*this.parent.deactivate()
	Endif
Endproc

Procedure MouseLeave
	Lparameters nButton, nShift, nXcoord, nycoord
	If This.Parent.nmonth=This.nmonth
		This.ForeColor=This.yf    &&Rgb(0,0,0)
		This.FontBold=.F.
	Endif
Endproc

Procedure MouseEnter
	Lparameters nButton, nShift, nXcoord, nycoord
	If This.Parent.nmonth=This.nmonth
		This.yf=This.ForeColor
		This.ForeColor=This.Parent.color_texthighlight01
		This.FontBold=.T.
	Endif
Endproc

Procedure MouseDown
	Lparameters nButton, nShift, nXcoord, nycoord
	lnHandle = Thisform.HWnd
	param1 = 274
	param2 = 0xF012
	Declare Integer ReleaseCapture In WIN32API
	Declare Integer SendMessage In WIN32API Integer, Integer, Integer, Integer
	bb=ReleaseCapture()
	bb=SendMessage(lnHandle, param1, param2,0)
Endproc


Enddefine
*-- EndDefine: calendar_lbl1
********************
* HexToStr
********************
Define Class yspin As Spinner
Height = 22
BorderStyle=0
KeyboardHighValue = 2016+10
KeyboardLowValue = 2016-10
Left = 180
SpinnerHighValue =  2016+10
SpinnerLowValue =   2016-10
Top = 0
Width = 16
Value = 1
Name = "Spinner1"

Procedure Init
	This.Value=Year(Date())
Endproc

Procedure InteractiveChange
	Thisform.yearselect(This.Value)
Endproc
Enddefine
*-- EndDefine:yspin
*******************
Define Class yhelp As OptionGroup
AutoSize = .T.
ButtonCount = 1
BackStyle = 0
BorderStyle = 0
Value = 1
Height = 27
Left = 36
MousePointer = 15
Top = 84
Width = 28
ToolTipText = "Help"
Name = "Optiongroup1"
Option1.Caption = ""
Option1.Value = 1
Option1.Height = 17
Option1.Left = 5
Option1.Top = 5
Option1.Width = 18
Option1.AutoSize = .T.
Option1.MousePointer=15
Option1.Name = "Option1"

Procedure Click
	Local m.myvar
	TEXT to m.myvar noshow
this is a calendar originally downloaded from
https://www.universalthread.com/ViewPageNewDownload.aspx?ID=33853
calendar.zip
Emmanuel Galanopoulos Athens
Graphical Month Calendar
Tuesday, November 13th, 2007 at 09h52

-added capabilities below
1-standalone calendar as top level form
2-contextuel menu to set
	3-forecolors
	4-gradients backcolors (can fix random to ones in code)
	5-configurable transparency ( 170-255)
	6-replacing images buttons with labels with webding font
	7-replacing 2 contextuels menus with spinner
	8-moving by mousedown the calendar (in labels at top and bottom left)
	9-a help button
For the demo i choosen random colors.can fiw some colors wanted...	
Of course can build a project,add a config.fpw and compile an exe.	
	ENDTEXT

	Messagebox(m.myvar,0+32+4096,"Summary help")
Endproc

Enddefine
*
*-- EndDefine: yhelp
********************
Function HexToStr(cBytes)
Local cReturn,N
cReturn=""
For N=Len(cBytes)/2 To 1 Step -1
	nChr=Eval("0x"+Substr(cBytes,(N-1)*2+1,2))
	cReturn=cReturn+Chr(nChr)
Endfor
Return cReturn
Endfunc

* DateToMonth
***********************
Function DateToMonth(ddate)
Return Cmonth(ddate)
Endfunc


A configurable desktop calendar
A configurable desktop calendar
A configurable desktop calendar
A configurable desktop calendar

Important:All Codes above are tested on VFP9SP2 & windows 10 pro

To be informed of the latest articles, subscribe:
Comment on this post