Yet Another VFP themed calendar

Published on by Yousfi Benameur


this is another simple vfp calendar built with another method.
ycal class is composed of 2 containers and contains hear(yday label),days of months(max=37 to receive all days of any month)
2 spinners (month,year) and the day date.
teh calendar is draggable from  the small red shape at bottom.
this class can easily converted to visual class (vcx/vct) and dropped on any form (showWindow=0,1,2) or in _screen.
it can be created as a COM object (createobject,newObject).
this demo code build 12 calendars with diffrent themes.
Any calendar can be customized in all controls properties (container,label).
The good of this calendar is that the container control have a picture property desserving cool backgrounds calendar.So can produce a great quantity of various calendar themes.
Of course the images dimensions choosen are important for container background(filled with clip images..)
Note: the calendar header "Lu Ma Me Je Ve Sa Di" is in French but can substitute it with English...as "Mo Tu We Th Fr Sa Su"  "(in code ).


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


*1* 12 calendars demo from the class ycal
*the code downloads 11 images to folder source\images for this demo.

Publi  m.yim
m.yim=Addbs(Justpath(Sys(16,1)))+"images"

If !Directory (m.yim)
    Md (m.yim)
Endi
m.yim=Addbs(m.yim)

Do ydownload   &&can replace images folder with yours and modify the demo code.



Publi yform
yform=Newobject("ycalendar")
yform.Show
Read Events
Retu
*
Define Class ycalendar As Form
	Height = 592
	Width = 864
	ShowWindow = 2
	ScrollBars = 2
	DoCreate = .T.
	AutoCenter = .T.
	Caption = "yCalendars (prg class) !12 themed  vfp calendars"
	BackColor = Rgb(0,0,0)
	Name = "Form1"

	Procedure Init
	
		With Thisform
		
			.AddObject("ycal1","ycal")
			With .ycal1
				DoDefault()
				.Lang=0
				.SpecialEffect=1
				.BorderColor=Rgb(0,255,0)
				.BorderWidth=2
				.Style=0
				.Visible=.T.
				.Left=10
				.Top=10
			Endwith
		
			.AddObject("ycal2","ycal")
			With .ycal2
				DoDefault()
				.Picture=m.yim+"1.JPG"
				.ycont.Picture=.Picture
				.SetAll("backstyle",0,"label")
				.SetAll("forecolor",Rgb(200,125,87),"label")
				.SpecialEffect=1
				.Style=3

				.Visible=.T.
				.Left=.Parent.ycal1.Left+.Parent.ycal1.Width+10
				.Top=10
			Endwith
		
			.AddObject("ycal3","ycal")
			With .ycal3
				DoDefault()
				xpicture=m.yim+"2.gif"
				.ycont.Picture=m.xpicture
				.SetAll("backstyle",0,"label")
				.SetAll("forecolor",Rgb(100,225,187),"label")
				With .ycont.yday
					.ForeColor=Rgb(128,255,0)
					.BackColor=Rgb(255,255,206)
					.BorderStyle=1
				Endwith
				.SpecialEffect=1
				.Style=3

				.Visible=.T.
				.Left=.Parent.ycal2.Left+.Parent.ycal2.Width+10
				.Top=10
			Endwith
			
			.AddObject("ycal4","ycal")
			With .ycal4
				DoDefault()
				.Picture=m.yim+"3.gif"
				.ycont.Picture=.Picture
				.SetAll("backstyle",0,"label")
				.SetAll("forecolor",Rgb(100,225,18),"label")
				With .ycont.yday
					.ForeColor=255
					.BackColor=Rgb(255,255,206)
					.BorderStyle=1
					.FontName="segoe script"
				Endwith
				.ycont.yday.BackStyle=1
				.SpecialEffect=0
				*.style=3

				.Visible=.T.
				.Left=.Parent.ycal3.Left+.Parent.ycal3.Width+10
				.Top=10
			Endwith
			

			.AddObject("ycal5","ycal")
			With .ycal5
				DoDefault()
				xpicture=m.yim+"4.JPG"
				.ycont.Picture=m.xpicture
				.SetAll("backstyle",0,"label")
				.SetAll("forecolor",255,"label")
				.SpecialEffect=1
				*.style=3

				.Visible=.T.
				.Left=10
				.Top=.Parent.ycal1.Top+.Parent.ycal1.Height+10
			Endwith
			

			.AddObject("ycal6","ycal")
			With .ycal6
				DoDefault()
				xpicture=m.yim+"5.JPG"
				.ycont.Picture=m.xpicture
				.SetAll("backstyle",0,"label")
				.SetAll("forecolor",Rgb(0,255,0),"label")
				.SpecialEffect=1
				*.style=3

				.Visible=.T.
				.Left=.Parent.ycal5.Left+.Parent.ycal5.Width+10
				.Top=.Parent.ycal5.Top
			Endwith
			
			.AddObject("ycal7","ycal")
			With .ycal7
				DoDefault()
				.Picture=m.yim+"6.JPG"
				.ycont.Picture=.Picture
				.SetAll("backstyle",0,"label")
				.SetAll("forecolor",Rgb(255,255,255),"label")
				.SpecialEffect=1
				*.style=3
				.Visible=.T.
				.Left=.Parent.ycal6.Left+.Parent.ycal6.Width+10
				.Top=.Parent.ycal6.Top
			Endwith
			
			.AddObject("ycal8","ycal")
			With .ycal8
				DoDefault()
				xpicture=m.yim+"7.JPG"

				.ycont.Picture=xpicture
				.SetAll("backstyle",0,"label")
				.SetAll("forecolor",Rgb(128,0,64),"label")
				.SpecialEffect=1
				.Style=3
				.Visible=.T.
				.Left=.Parent.ycal7.Left+.Parent.ycal7.Width+10
				.Top=.Parent.ycal7.Top
			Endwith
		
			.AddObject("ycal9","ycal")
			With .ycal9
				DoDefault()
				xpicture=m.yim+"8.JPG"

				.ycont.Picture=xpicture
				.SetAll("backstyle",0,"label")
				.SetAll("forecolor",Rgb(128,0,64),"label")
				.SpecialEffect=1
				.Style=3
				.Visible=.T.
				.Left=10
				.Top=.Parent.ycal5.Top+.Parent.ycal5.Height+10
			Endwith
			
			.AddObject("ycal10","ycal")
			With .ycal10
				DoDefault()
				xpicture=m.yim+"9.GIF"

				.ycont.Picture=xpicture
				.SetAll("backstyle",0,"label")
				.SetAll("forecolor",Rgb(128,0,64),"label")
				.SpecialEffect=1
				.Style=3
				.Visible=.T.
				.Left=.Parent.ycal9.Left+.Parent.ycal9.Width+10
				.Top=.Parent.ycal9.Top
			Endwith
			
			.AddObject("ycal11","ycal")
			With .ycal11
				DoDefault()
				xpicture=m.yim+"10.JPG"

				.ycont.Picture=xpicture
				.SetAll("backstyle",0,"label")
				.SetAll("forecolor",Rgb(0,0,255),"label")
				.SpecialEffect=1
				.Style=3
				.Visible=.T.
				.Left=.Parent.ycal10.Left+.Parent.ycal10.Width+10
				.Top=.Parent.ycal10.Top
			Endwith
			
			.AddObject("ycal12","ycal")
			With .ycal12
				DoDefault()
				xpicture=m.yim+"11.GIF"

				.ycont.Picture=xpicture
				.SetAll("backstyle",0,"label")
				.SetAll("forecolor",Rgb(255,255,0),"label")
				.SpecialEffect=1
				.Style=3  &&
				.Visible=.T.
				.Left=.Parent.ycal11.Left+.Parent.ycal11.Width+10
				.Top=.Parent.ycal11.Top
			Endwith
			

		Endwith

		Retu


		*CAN set all properties as:
		*-container:backcolor,picture,specialeffect
		*-labels days: backcolor,forecolor,backstyle
		*-header:backcolor,forecolor,backstyle,fontname,fontsize
	Endproc


	Procedure Destroy
		Clea Events
	Endproc


Enddefine
*
*-- EndDefine: ycalendar

*
Define Class ycal As Container
	Width = 202
	Height = 280
	SpecialEffect = 1
	BackColor = Rgb(0,0,0)
	Style = 3
	ybackcolor = Rgb(255,255,0)
	Lang=0  &&frenbch
	Name = "ycal"

	Add Object ycont As ycont With ;
		Top = 6, ;
		Left = 4, ;
		Width = 192, ;
		Height = 228, ;
		SpecialEffect = 1, ;
		BackColor = Rgb(128,255,255), ;
		Name = "yCont"



	Add Object spinner2 As Spinner With ;
		FontBold = .T., ;
		BorderStyle = 0, ;
		Height = 20, ;
		KeyboardHighValue = 2100, ;
		KeyboardLowValue = 1900, ;
		Left = 134, ;
		MousePointer = 15, ;
		SpinnerHighValue = 2100.00, ;
		SpinnerLowValue = 1900.00, ;
		Top = 238, ;
		Width = 59, ;
		Value = 2016, ;
		Name = "Spinner2"


	Add Object spinner1 As Spinner With ;
		FontBold = .T., ;
		BorderStyle = 0, ;
		Height = 20, ;
		KeyboardHighValue = 12, ;
		KeyboardLowValue = 1, ;
		Left = 76, ;
		MousePointer = 15, ;
		SpinnerHighValue =  12.00, ;
		SpinnerLowValue =   1.00, ;
		Top = 238, ;
		Width = 48, ;
		Value = 1, ;
		Name = "Spinner1"


	Add Object label1 As Label With ;
		AutoSize = .T., ;
		FontBold = .T., ;
		BackStyle = 0, ;
		Caption = "This.day", ;
		Height = 17, ;
		Left = 8, ;
		MousePointer = 15, ;
		Top = 243, ;
		Width = 49, ;
		ForeColor = Rgb(0,255,255), ;
		Name = "Label1"


	Add Object shape1 As Shape With ;
		Top = 264, ;
		Left = 4, ;
		Height = 13, ;
		Width = 13, ;
		BorderWidth = 2, ;
		Curvature = 99, ;
		MousePointer = 15, ;
		BackColor = Rgb(255,0,0), ;
		Name = "Shape1"


	Procedure ybuild
		Lparameters xmonth,xyear
		*do case
		*case this.lang=0
		*set date french
		*otherwise
		*set date english
		*endcase
		xday=Int(Val(Substr(Dtoc(Date()),1,2)))
		Do Case
			Case xmonth=1
				xmax=31
			Case xmonth=2
				If Day(Ctod("29/02/"+Trans(xyear)))=29
					xmax=29
				Else
					xmax=28
				Endi
			Case xmonth=3
				xmax=31
			Case xmonth=4
				xmax=30
			Case xmonth=5
				xmax=31
			Case xmonth=6
				xmax=30
			Case xmonth=7
				xmax=31
			Case xmonth=8
				xmax=31
			Case xmonth=9
				xmax=30
			Case xmonth=10
				xmax=31
			Case xmonth=11
				xmax=30
			Case xmonth=12
				xmax=31
		Endcase

		xd=Datetime(xyear,xmonth,1)
		xfirst=Substr(Cdow(xd),1,2)


		If This.Lang=0
			&&french
			Do Case
				Case xfirst="lu"
					xf=1
				Case xfirst="ma"
					xf=2
				Case xfirst="me"
					xf=3
				Case xfirst="je"
					xf=4
				Case xfirst="ve"
					xf=5
				Case xfirst="sa"
					xf=6
				Case xfirst="di"
					xf=7
			Endcase
		Endi

		*if this.lang>0  &&english...
		*&&English
		*do case
		*case xfirst="mo"
		*xf=1
		*case xfirst="tu"
		*xf=2
		*case xfirst="we"
		*xf=3
		*case xfirst="th"
		*xf=4
		*case xfirst="fr"
		*xf=5
		*case xfirst="sa"
		*xf=6
		*case xfirst="su"
		*xf=7
		*endcase
		*endi

		With This.ycont
			For i=1 To 37
				x=Eval(".lab"+Trans(i))
				x.Caption=""
			Endfor


			j=1
			For i=xf To 37  &&37 for all cases of months
				If j<=xmax
					x=Eval(".lab"+Trans(i))
					x.Caption=Trans(j)
					If j=xday And Month(Date())=xmonth And Year(Date())=xyear
						x.BackColor=Rgb(0,255,0)
						x.BorderStyle=1
					Else
						x.BackColor=This.ybackcolor
						x.BorderStyle=0
					Endi
					j=j+1
				Else
					Exit
				Endi
			Endfor

			Set Date Long
			.yday.Caption=Upper(Dtoc(Date()))
			Set Date short
		Endwith
	Endproc


	Procedure my
		Lparameters oSource, nXCoord, nYCoord
		oSource.Left = nXCoord - This.Parent.XOffset
		oSource.Top  = nYCoord - This.Parent.YOffset
	Endproc


	Procedure my1
		Lparameters nButton, nShift, nXCoord, nYCoord
		*--- aevent create an array laEvents
		Aevents( myArray, 0)
		*--- reference the calling object
		loObject = myArray[1]

		yy=Datetime(This.spinner2.Value,This.spinner1.Value,Int(Val(loObject.Caption)))
		Set Date Long
		_Cliptext=Dtoc(yy)
		Messagebox(Dtoc(yy),0+32+4096,"Date in clipboard",1200)
		Set Date short
	Endproc


	Procedure DragDrop
		Lparameters oSource, nXCoord, nYCoord
		*binded to parent class (form mandatory)
	Endproc


	Procedure Init
		*this.addproperty("ybackcolor",rgb(255,255,0))
		This.ybackcolor=Rgb(255,255,0)

		Set Date short

		*try
		With This.Parent
			.AddProperty("xoffset",0)
			.AddProperty("yOffset",0)
		Endwith
		*catch
		*endtry
		Bindevent(This.Parent,"dragDrop",This,"my")


		With This.ycont
			.SetAll("backstyle",1,"label")
			.SetAll("backcolor",.Parent.ybackcolor,"label")

			For i=1 To 7
				x=Eval(".label"+Trans(i))
				x.ForeColor=255
				x.BackColor=Rgb(0,255,0)
			Endfor
			.yday.BackStyle=0

			.SetAll("borderstyle",0,"label")
			For i=1 To .ControlCount
				If  i>=8
					.Controls(i).Caption=""
				Endi
			Endfor
		Endwith

		With This.spinner1
			.Value=Month(Date())
			.InteractiveChange()
		Endwith

		For i=1 To 37
			x=Eval("this.ycont.lab"+Trans(i))
			If !Empty(x.Caption)
				Bindevent(x,"mousedown",This,"my1")
			Endi
		Endfor
	Endproc


	Procedure spinner2.InteractiveChange
		Try
			This.Parent.ybuild(This.Parent.spinner1.Value,This.Value)
		Catch
		Endtry
	Endproc


	Procedure spinner1.InteractiveChange
		Try
			This.Parent.ybuild(This.Value,This.Parent.spinner2.Value)
		Catch
		Endtry
	Endproc


	Procedure label1.Click
		With This.Parent
			.spinner1.Value=Month(Date())
			.spinner2.Value=Year(Date())
			.spinner1.InteractiveChange()
		Endwith
	Endproc


	Procedure shape1.MouseMove
		Lparameters nButton, nShift, nXCoord, nYCoord
		If nButton = 1 && Left button
			This.Parent.Parent.XOffset = nXCoord - This.Parent.Left
			This.Parent.Parent.YOffset = nYCoord - This.Parent.Top
			This.Parent.Drag
		Endif
	Endproc


	Procedure shape1.DragDrop
		Lparameters oSource, nXCoord, nYCoord
		This.Parent.Parent.DragDrop(oSource, nXCoord, nYCoord)
	Endproc


	Procedure shape1.MouseDown
		Lparameters nButton, nShift, nXCoord, nYCoord
	Endproc


Enddefine
*
*-- EndDefine: ycal


*ycont
Define Class ycont As Container
	Top = 99
	Left = 110
	Width = 192
	Height = 228
	SpecialEffect = 1
	BackColor = Rgb(128,255,255)
	Name = "yCont"

	Add Object label1 As Label With ;
		FontBold = .T., ;
		FontSize = 12, ;
		Anchor = 15, ;
		Alignment = 2, ;
		BackStyle = 0, ;
		BorderStyle = 0, ;
		Caption = "Lu", ;
		Height = 20, ;
		Left = 11, ;
		Top = 34, ;
		Width = 20, ;
		Name = "Label1"

	Add Object label2 As Label With ;
		FontBold = .T., ;
		FontSize = 12, ;
		Anchor = 15, ;
		Alignment = 2, ;
		BackStyle = 0, ;
		BorderStyle = 0, ;
		Caption = "Ma", ;
		Height = 20, ;
		Left = 36, ;
		Top = 34, ;
		Width = 20, ;
		Name = "Label2"


	Add Object label3 As Label With ;
		FontBold = .T., ;
		FontSize = 12, ;
		Anchor = 15, ;
		Alignment = 2, ;
		BackStyle = 0, ;
		BorderStyle = 0, ;
		Caption = "Me", ;
		Height = 20, ;
		Left = 60, ;
		Top = 34, ;
		Width = 20, ;
		Name = "Label3"

	Add Object label4 As Label With ;
		FontBold = .T., ;
		FontSize = 12, ;
		Anchor = 15, ;
		Alignment = 2, ;
		BackStyle = 0, ;
		BorderStyle = 0, ;
		Caption = "Je", ;
		Height = 20, ;
		Left = 84, ;
		Top = 34, ;
		Width = 20, ;
		Name = "Label4"

	Add Object label5 As Label With ;
		FontBold = .T., ;
		FontSize = 12, ;
		Anchor = 15, ;
		Alignment = 2, ;
		BackStyle = 0, ;
		BorderStyle = 0, ;
		Caption = "Ve", ;
		Height = 20, ;
		Left = 109, ;
		Top = 34, ;
		Width = 20, ;
		Name = "Label5"

	Add Object label6 As Label With ;
		FontBold = .T., ;
		FontSize = 12, ;
		Anchor = 15, ;
		Alignment = 2, ;
		BackStyle = 0, ;
		BorderStyle = 0, ;
		Caption = "Sa", ;
		Height = 20, ;
		Left = 133, ;
		Top = 34, ;
		Width = 20, ;
		Name = "Label6"

	Add Object label7 As Label With ;
		FontBold = .T., ;
		FontSize = 12, ;
		Anchor = 15, ;
		Alignment = 2, ;
		BackStyle = 0, ;
		BorderStyle = 0, ;
		Caption = "Di", ;
		Height = 20, ;
		Left = 157, ;
		Top = 34, ;
		Width = 20, ;
		Name = "Label7"

	Add Object lab1 As Label With ;
		FontBold = .T., ;
		FontSize = 12, ;
		Anchor = 15, ;
		Alignment = 2, ;
		BackStyle = 0, ;
		BorderStyle = 1, ;
		Caption = "1", ;
		Height = 20, ;
		Left = 10, ;
		Top = 61, ;
		Width = 20, ;
		Name = "lab1"

	Add Object lab2 As Label With ;
		FontBold = .T., ;
		FontSize = 12, ;
		Anchor = 15, ;
		Alignment = 2, ;
		BackStyle = 0, ;
		BorderStyle = 1, ;
		Caption = "1", ;
		Height = 20, ;
		Left = 35, ;
		Top = 61, ;
		Width = 20, ;
		Name = "lab2"

	Add Object lab3 As Label With ;
		FontBold = .T., ;
		FontSize = 12, ;
		Anchor = 15, ;
		Alignment = 2, ;
		BackStyle = 0, ;
		BorderStyle = 1, ;
		Caption = "1", ;
		Height = 20, ;
		Left = 59, ;
		Top = 61, ;
		Width = 20, ;
		Name = "lab3"


	Add Object lab4 As Label With ;
		FontBold = .T., ;
		FontSize = 12, ;
		Anchor = 15, ;
		Alignment = 2, ;
		BackStyle = 0, ;
		BorderStyle = 1, ;
		Caption = "1", ;
		Height = 20, ;
		Left = 83, ;
		Top = 61, ;
		Width = 20, ;
		Name = "lab4"


	Add Object lab5 As Label With ;
		FontBold = .T., ;
		FontSize = 12, ;
		Anchor = 15, ;
		Alignment = 2, ;
		BackStyle = 0, ;
		BorderStyle = 1, ;
		Caption = "1", ;
		Height = 20, ;
		Left = 108, ;
		Top = 61, ;
		Width = 20, ;
		Name = "lab5"

	Add Object lab6 As Label With ;
		FontBold = .T., ;
		FontSize = 12, ;
		Anchor = 15, ;
		Alignment = 2, ;
		BackStyle = 0, ;
		BorderStyle = 1, ;
		Caption = "1", ;
		Height = 20, ;
		Left = 132, ;
		Top = 61, ;
		Width = 20, ;
		Name = "lab6"

	Add Object lab7 As Label With ;
		FontBold = .T., ;
		FontSize = 12, ;
		Anchor = 15, ;
		Alignment = 2, ;
		BackStyle = 0, ;
		BorderStyle = 1, ;
		Caption = "1", ;
		Height = 20, ;
		Left = 156, ;
		Top = 61, ;
		Width = 20, ;
		Name = "lab7"


	Add Object lab8 As Label With ;
		FontBold = .T., ;
		FontSize = 12, ;
		Anchor = 15, ;
		Alignment = 2, ;
		BackStyle = 0, ;
		BorderStyle = 1, ;
		Caption = "1", ;
		Height = 20, ;
		Left = 10, ;
		Top = 88, ;
		Width = 20, ;
		Name = "lab8"


	Add Object lab9 As Label With ;
		FontBold = .T., ;
		FontSize = 12, ;
		Anchor = 15, ;
		Alignment = 2, ;
		BackStyle = 0, ;
		BorderStyle = 1, ;
		Caption = "1", ;
		Height = 20, ;
		Left = 35, ;
		Top = 88, ;
		Width = 20, ;
		Name = "lab9"


	Add Object lab10 As Label With ;
		FontBold = .T., ;
		FontSize = 12, ;
		Anchor = 15, ;
		Alignment = 2, ;
		BackStyle = 0, ;
		BorderStyle = 1, ;
		Caption = "1", ;
		Height = 20, ;
		Left = 59, ;
		Top = 88, ;
		Width = 20, ;
		Name = "lab10"

	Add Object lab11 As Label With ;
		FontBold = .T., ;
		FontSize = 12, ;
		Anchor = 15, ;
		Alignment = 2, ;
		BackStyle = 0, ;
		BorderStyle = 1, ;
		Caption = "1", ;
		Height = 20, ;
		Left = 83, ;
		Top = 88, ;
		Width = 20, ;
		Name = "lab11"

	Add Object lab12 As Label With ;
		FontBold = .T., ;
		FontSize = 12, ;
		Anchor = 15, ;
		Alignment = 2, ;
		BackStyle = 0, ;
		BorderStyle = 1, ;
		Caption = "1", ;
		Height = 20, ;
		Left = 108, ;
		Top = 88, ;
		Width = 20, ;
		Name = "lab12"


	Add Object lab13 As Label With ;
		FontBold = .T., ;
		FontSize = 12, ;
		Anchor = 15, ;
		Alignment = 2, ;
		BackStyle = 0, ;
		BorderStyle = 1, ;
		Caption = "1", ;
		Height = 20, ;
		Left = 132, ;
		Top = 88, ;
		Width = 20, ;
		Name = "lab13"

	Add Object lab14 As Label With ;
		FontBold = .T., ;
		FontSize = 12, ;
		Anchor = 15, ;
		Alignment = 2, ;
		BackStyle = 0, ;
		BorderStyle = 1, ;
		Caption = "1", ;
		Height = 20, ;
		Left = 156, ;
		Top = 88, ;
		Width = 20, ;
		Name = "lab14"

	Add Object lab15 As Label With ;
		FontBold = .T., ;
		FontSize = 12, ;
		Anchor = 15, ;
		Alignment = 2, ;
		BackStyle = 0, ;
		BorderStyle = 1, ;
		Caption = "1", ;
		Height = 20, ;
		Left = 10, ;
		Top = 113, ;
		Width = 20, ;
		Name = "lab15"

	Add Object lab16 As Label With ;
		FontBold = .T., ;
		FontSize = 12, ;
		Anchor = 15, ;
		Alignment = 2, ;
		BackStyle = 0, ;
		BorderStyle = 1, ;
		Caption = "1", ;
		Height = 20, ;
		Left = 35, ;
		Top = 113, ;
		Width = 20, ;
		Name = "lab16"


	Add Object lab17 As Label With ;
		FontBold = .T., ;
		FontSize = 12, ;
		Anchor = 15, ;
		Alignment = 2, ;
		BackStyle = 0, ;
		BorderStyle = 1, ;
		Caption = "1", ;
		Height = 20, ;
		Left = 59, ;
		Top = 113, ;
		Width = 20, ;
		Name = "lab17"

	Add Object lab18 As Label With ;
		FontBold = .T., ;
		FontSize = 12, ;
		Anchor = 15, ;
		Alignment = 2, ;
		BackStyle = 0, ;
		BorderStyle = 1, ;
		Caption = "1", ;
		Height = 20, ;
		Left = 83, ;
		Top = 113, ;
		Width = 20, ;
		Name = "lab18"

	Add Object lab19 As Label With ;
		FontBold = .T., ;
		FontSize = 12, ;
		Anchor = 15, ;
		Alignment = 2, ;
		BackStyle = 0, ;
		BorderStyle = 1, ;
		Caption = "1", ;
		Height = 20, ;
		Left = 108, ;
		Top = 113, ;
		Width = 20, ;
		Name = "lab19"

	Add Object lab20 As Label With ;
		FontBold = .T., ;
		FontSize = 12, ;
		Anchor = 15, ;
		Alignment = 2, ;
		BackStyle = 0, ;
		BorderStyle = 1, ;
		Caption = "1", ;
		Height = 20, ;
		Left = 132, ;
		Top = 113, ;
		Width = 20, ;
		Name = "lab20"

	Add Object lab21 As Label With ;
		FontBold = .T., ;
		FontSize = 12, ;
		Anchor = 15, ;
		Alignment = 2, ;
		BackStyle = 0, ;
		BorderStyle = 1, ;
		Caption = "1", ;
		Height = 20, ;
		Left = 156, ;
		Top = 113, ;
		Width = 20, ;
		Name = "lab21"

	Add Object lab22 As Label With ;
		FontBold = .T., ;
		FontSize = 12, ;
		Anchor = 15, ;
		Alignment = 2, ;
		BackStyle = 0, ;
		BorderStyle = 1, ;
		Caption = "1", ;
		Height = 20, ;
		Left = 10, ;
		Top = 141, ;
		Width = 20, ;
		Name = "lab22"

	Add Object lab23 As Label With ;
		FontBold = .T., ;
		FontSize = 12, ;
		Anchor = 15, ;
		Alignment = 2, ;
		BackStyle = 0, ;
		BorderStyle = 1, ;
		Caption = "1", ;
		Height = 20, ;
		Left = 35, ;
		Top = 141, ;
		Width = 20, ;
		Name = "lab23"

	Add Object lab24 As Label With ;
		FontBold = .T., ;
		FontSize = 12, ;
		Anchor = 15, ;
		Alignment = 2, ;
		BackStyle = 0, ;
		BorderStyle = 1, ;
		Caption = "1", ;
		Height = 20, ;
		Left = 59, ;
		Top = 141, ;
		Width = 20, ;
		Name = "lab24"

	Add Object lab25 As Label With ;
		FontBold = .T., ;
		FontSize = 12, ;
		Anchor = 15, ;
		Alignment = 2, ;
		BackStyle = 0, ;
		BorderStyle = 1, ;
		Caption = "1", ;
		Height = 20, ;
		Left = 83, ;
		Top = 141, ;
		Width = 20, ;
		Name = "lab25"


	Add Object lab26 As Label With ;
		FontBold = .T., ;
		FontSize = 12, ;
		Anchor = 15, ;
		Alignment = 2, ;
		BackStyle = 0, ;
		BorderStyle = 1, ;
		Caption = "1", ;
		Height = 20, ;
		Left = 108, ;
		Top = 141, ;
		Width = 20, ;
		Name = "lab26"

	Add Object lab27 As Label With ;
		FontBold = .T., ;
		FontSize = 12, ;
		Anchor = 15, ;
		Alignment = 2, ;
		BackStyle = 0, ;
		BorderStyle = 1, ;
		Caption = "1", ;
		Height = 20, ;
		Left = 132, ;
		Top = 141, ;
		Width = 20, ;
		Name = "lab27"

	Add Object lab28 As Label With ;
		FontBold = .T., ;
		FontSize = 12, ;
		Anchor = 15, ;
		Alignment = 2, ;
		BackStyle = 0, ;
		BorderStyle = 1, ;
		Caption = "1", ;
		Height = 20, ;
		Left = 156, ;
		Top = 141, ;
		Width = 20, ;
		Name = "lab28"

	Add Object lab29 As Label With ;
		FontBold = .T., ;
		FontSize = 12, ;
		Anchor = 15, ;
		Alignment = 2, ;
		BackStyle = 0, ;
		BorderStyle = 1, ;
		Caption = "1", ;
		Height = 20, ;
		Left = 8, ;
		Top = 167, ;
		Width = 20, ;
		Name = "lab29"

	Add Object lab30 As Label With ;
		FontBold = .T., ;
		FontSize = 12, ;
		Anchor = 15, ;
		Alignment = 2, ;
		BackStyle = 0, ;
		BorderStyle = 1, ;
		Caption = "1", ;
		Height = 20, ;
		Left = 33, ;
		Top = 167, ;
		Width = 20, ;
		Name = "lab30"

	Add Object lab31 As Label With ;
		FontBold = .T., ;
		FontSize = 12, ;
		Anchor = 15, ;
		Alignment = 2, ;
		BackStyle = 0, ;
		BorderStyle = 1, ;
		Caption = "1", ;
		Height = 20, ;
		Left = 57, ;
		Top = 167, ;
		Width = 20, ;
		Name = "lab31"

	Add Object lab32 As Label With ;
		FontBold = .T., ;
		FontSize = 12, ;
		Anchor = 15, ;
		Alignment = 2, ;
		BackStyle = 0, ;
		BorderStyle = 1, ;
		Caption = "1", ;
		Height = 20, ;
		Left = 81, ;
		Top = 167, ;
		Width = 20, ;
		Name = "lab32"

	Add Object lab33 As Label With ;
		FontBold = .T., ;
		FontSize = 12, ;
		Anchor = 15, ;
		Alignment = 2, ;
		BackStyle = 0, ;
		BorderStyle = 1, ;
		Caption = "1", ;
		Height = 20, ;
		Left = 106, ;
		Top = 167, ;
		Width = 20, ;
		Name = "lab33"

	Add Object lab34 As Label With ;
		FontBold = .T., ;
		FontSize = 12, ;
		Anchor = 15, ;
		Alignment = 2, ;
		BackStyle = 0, ;
		BorderStyle = 1, ;
		Caption = "1", ;
		Height = 20, ;
		Left = 130, ;
		Top = 167, ;
		Width = 20, ;
		Name = "lab34"

	Add Object lab35 As Label With ;
		FontBold = .T., ;
		FontSize = 12, ;
		Anchor = 15, ;
		Alignment = 2, ;
		BackStyle = 0, ;
		BorderStyle = 1, ;
		Caption = "1", ;
		Height = 20, ;
		Left = 154, ;
		Top = 167, ;
		Width = 20, ;
		Name = "lab35"

	Add Object yday As Label With ;
		FontBold = .T., ;
		Alignment = 2, ;
		BackStyle = 0, ;
		Caption = "", ;
		Height = 20, ;
		Left = 4, ;
		Top = 4, ;
		Width = 181, ;
		ForeColor = Rgb(0,0,255), ;
		Name = "yday"

	Add Object lab36 As Label With ;
		FontBold = .T., ;
		FontSize = 12, ;
		Anchor = 15, ;
		Alignment = 2, ;
		BackStyle = 0, ;
		BorderStyle = 1, ;
		Caption = "1", ;
		Height = 20, ;
		Left = 9, ;
		Top = 192, ;
		Width = 20, ;
		Name = "lab36"

	Add Object lab37 As Label With ;
		FontBold = .T., ;
		FontSize = 12, ;
		Anchor = 15, ;
		Alignment = 2, ;
		BackStyle = 0, ;
		BorderStyle = 1, ;
		Caption = "1", ;
		Height = 20, ;
		Left = 36, ;
		Top = 192, ;
		Width = 20, ;
		Name = "lab37"

Enddefine
*
*-- EndDefine: ycont

Procedure ydownload
	*download the picture used in code.if dont have internet connect , replace by  local images
	Declare Integer URLDownloadToFile In urlmon.Dll Integer pCaller, String szURL, String szFileName, Integer dwReserved, Integer lpfnCB
	Declare Integer DeleteUrlCacheEntry In wininet String lpszUrlName
    Declare integer Sleep in kernel32 integer
    
	Local lcDownloadURL,lcDownloadLoc,lnResult
	For i=1 To 11
    do case
	Case i=1
		lcDownloadURL = "http://img.over-blog-kiwi.com/1/43/54/07/20160307/ob_be7b50_1.jpg"
		lcDownloadLoc =m.yim+ "1.jpg"

	Case i=2
		lcDownloadURL = "http://img.over-blog-kiwi.com/1/43/54/07/20160307/ob_9e0ad3_2.gif"
		lcDownloadLoc = m.yim+"2.gif"

	Case i=3
		lcDownloadURL = "http://img.over-blog-kiwi.com/1/43/54/07/20160307/ob_26fe0a_3.gif"
		lcDownloadLoc = m.yim+"3.gif"

	Case i=4
		lcDownloadURL = "http://img.over-blog-kiwi.com/1/43/54/07/20160307/ob_fadb5b_4.jpg"
		lcDownloadLoc = m.yim+"4.jpg"

	Case i=5
		lcDownloadURL = "http://img.over-blog-kiwi.com/1/43/54/07/20160307/ob_193682_5.jpg"
		lcDownloadLoc = m.yim+"5.jpg"

	Case i=6
		lcDownloadURL = "http://img.over-blog-kiwi.com/1/43/54/07/20160307/ob_8ca014_6.jpg"
		lcDownloadLoc = m.yim+"6.jpg"

	Case i=7
		lcDownloadURL = "http://img.over-blog-kiwi.com/1/43/54/07/20160307/ob_f85e16_7.jpg"
		lcDownloadLoc = m.yim+"7.jpg"

	Case i=8
		lcDownloadURL = "http://img.over-blog-kiwi.com/1/43/54/07/20160307/ob_76c8dd_8.jpg"
		lcDownloadLoc = m.yim+"8.jpg"

	Case i=9
		lcDownloadURL = "http://img.over-blog-kiwi.com/1/43/54/07/20160307/ob_eeba12_9.gif"
		lcDownloadLoc = m.yim+"9.gif"

	Case i=10
		lcDownloadURL = "http://img.over-blog-kiwi.com/1/43/54/07/20160307/ob_962216_10.jpg"
		lcDownloadLoc = m.yim+"10.jpg"

	Case i=11
		lcDownloadURL = "http://img.over-blog-kiwi.com/1/43/54/07/20160307/ob_a2afdd_11.gif"
		lcDownloadLoc = m.yim+"11.gif"
Endcase


lnResult = DeleteUrlCacheEntry(lcDownloadURL)
lnResult = URLDownloadToFile(0, lcDownloadURL, lcDownloadLoc , 0,0)
If lnResult = 0
	Wait Window "Download "+lcDownloadLoc +"  Complete" Nowait
	*Else
	*!*        Messagebox("Download fails")
Endi
sleep(1000)
Endfor


Yet Another VFP themed calendar
Yet Another VFP themed calendar

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


*2* this code creates one calendar with custom settings fired from a commanbutton on a form
*dont forget to add the defined class ycal (pick it from code *1*)  after this code and run this as prg to obtain one calendar as your custom settings.

publi yform
yform=newObject("asup")
yform.show
read events
retu
*
DEFINE CLASS asup AS form
    Height = 379
	Width = 330
	ShowWindow = 2
	DoCreate = .T.
	AutoCenter = .T.
	Caption = "Form1"
	BackColor = RGB(212,208,200)
	Name = "Form1"

	ADD OBJECT command1 AS commandbutton WITH ;
		Top = 12, ;
		Left = 12, ;
		Height = 25, ;
		Width = 108, ;
		FontBold = .T., ;
		Caption = "new Calendar ", ;
		MousePointer = 15, ;
		BackColor = RGB(128,255,0), ;
		Name = "Command1"

	PROCEDURE command1.Click
	
	*	Set Classlib To ycal AddI  &&or Set Classlib To locfile(""ycal.vcx") AddI &&if external vcx
		With Thisform
			Try
				If Vartype(.ycal1)="O"
					.RemoveObject(.ycal1.Name)
				Endi
			Catch
			Endtry

			.AddObject("ycal1","ycal")

			With .ycal1
				*settings
				.backcolor=0
				.ycont.Picture=getpict()
				.SetAll("backstyle",0,"label")
				.SetAll("forecolor",Rgb(200,125,87),"label")
				.SpecialEffect=1
				.BorderWidth=2
				.Bordercolor=rgb(0,255,0)
				.Style=3
				with .ycont.yday
				.forecolor=255
				.backstyle=1
				.borderstyle=1
				endwith
				*Properties:-container:backcolor,picture
				*           -labels days: backcolor;forecolor,backstyle
				*           -header:backcolor,forecolor,backstyle,fontname,fontsize
				*........
				.Visible=.T.
				.Left=This.Left+This.Width/2
				.Top=This.Top+This.Height+2
			Endwith
		Endwith
*		Release Classlib ycal
	ENDPROC
    
    PROCEDURE DESTROY
    CLEA EVENTS
	ENDPROC

ENDDEFINE
*
*-- EndDefine: asup


*add the class definition here

*Define Class ycal As Container
*................
*Enddefine
*enddefine ycal


Yet Another VFP themed calendar

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


*3* configure a fixed calendar without accessories as spinners, shape...simply make them invisible and resize th calendar height
*add the class ycal.vcx at bottom

Publi yform
yform=Newobject("asup")
yform.Show
Read Events
Retu
*
Define Class asup As Form
    Height = 379
	Width = 330
	ShowWindow = 2
	DoCreate = .T.
	AutoCenter = .T.
	Caption = "A fixed calendar"
	BackColor = Rgb(212,208,200)
	Name = "Form1"

	Add Object command1 As CommandButton With ;
		Top = 12, ;
		Left = 12, ;
		Height = 25, ;
		Width = 108, ;
		FontBold = .T., ;
		Caption = "new Calendar ", ;
		MousePointer = 15, ;
		BackColor = Rgb(128,255,0), ;
		Name = "Command1"

	Procedure command1.Click
		*dont forget to add the defined class ycal after this code and run this as prg to obtain one calendar as
		*your custom settings
	*	Set Classlib To Locfile("ycal.vcx")  AddI  &&if external vcx
		With Thisform
			Try
				If Vartype(.ycal1)="O"
					.RemoveObject(.ycal1.Name)
				Endi
			Catch
			Endtry

			.AddObject("ycal1","ycal")

			With .ycal1
				*settings
				.BackColor=Rgb(0,255,0)
				.ycont.Picture=Getpict()
				.SetAll("backstyle",0,"label")
				.SetAll("forecolor",Rgb(200,125,87),"label")
				.SpecialEffect=0
				.BorderWidth=1
				.BorderColor=Rgb(0,255,0)
				.Style=3
				With .ycont.yday
					.ForeColor=255
					.BackStyle=0
					.BorderStyle=0
				Endwith
				*Properties:-container:backcolor,picture,gradient
				*           -labels days: backcolor;forecolor,backstyle
				*           -header:backcolor,forecolor,backstyle,fontname,fontsize
				*........
				.spinner1.Visible=.F.
				.spinner2.Visible=.F.
				.label1.Visible=.F.
				.shape1.Visible=.F.
				.Height=.ycont.Height+14
				.Visible=.T.
				.Left=This.Left+This.Width/2
				.Top=This.Top+This.Height+2
			Endwith
		Endwith
*		Release Classlib ycal
	Endproc

	Procedure Destroy
		Clea Events
	Endproc

Enddefine
*
*-- EndDefine: asup


*add the class definition here

*Define Class ycal As Container
*................
*Enddefine
*enddefine ycal


Yet Another VFP themed calendar
These 11 images are downloaded automatically by the code above for theming 11 demo calendars
These 11 images are downloaded automatically by the code above for theming 11 demo calendars
These 11 images are downloaded automatically by the code above for theming 11 demo calendars
These 11 images are downloaded automatically by the code above for theming 11 demo calendars
These 11 images are downloaded automatically by the code above for theming 11 demo calendars
These 11 images are downloaded automatically by the code above for theming 11 demo calendars
These 11 images are downloaded automatically by the code above for theming 11 demo calendars
These 11 images are downloaded automatically by the code above for theming 11 demo calendars
These 11 images are downloaded automatically by the code above for theming 11 demo calendars
These 11 images are downloaded automatically by the code above for theming 11 demo calendars
These 11 images are downloaded automatically by the code above for theming 11 demo calendars

These 11 images are downloaded automatically by the code above for theming 11 demo calendars

Important:All Codes above are tested on VFP9SP2 & windows 10 pro. To avoid some problems with priveleges level, run vfp9.exe as administrator.

Please come back with any bug.correct code is usefull to all readers.

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