A configurable desktop calendar
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
Important:All Codes above are tested on VFP9SP2 & windows 10 pro