Level Extreme platform
Subscription
Corporate profile
Products & Services
Support
Legal
Français
Timeline
Message
From
18/12/2008 11:30:52
 
 
To
All
General information
Forum:
Visual FoxPro
Category:
Coding, syntax & commands
Title:
Timeline
Environment versions
Visual FoxPro:
VFP 9 SP2
OS:
Windows XP SP2
Network:
Windows XP
Database:
Visual FoxPro
Application:
Desktop
Miscellaneous
Thread ID:
01368556
Message ID:
01368556
Views:
52
Hi..
The following code means a timeline to show scheduling events... To some level of needs it works fine.. but if I need to open more months as 6 (or) 7 the form hangs e freeze... As well the mousemove behavior works weird and sometime seems also frozen.

I'm sharing this here on the try to fix this little problem... And my goal after this is about to turn this code available at Ut's download area

TIA

(humm.. almost forget.. other stuff is about on the try to use mousewheel feature)
oform = Newobject("myform")
oform.Width=oform.timeline1.Width
oform.Height=oform.timeline1.Height
oform.Show

Define Class myform As Form
	Caption = "Timeline for financial movement"
	listipwindow=.f.
	showtips=.t.
	Add Object  timeline As timeline With   Visible = .T., Name = "timeline1"

	Procedure Init
		This.timeline1.dDt_start=Date()-110
		This.timeline1.dDt_end=Date()+40
		This.timeline1.dDt_base=Date()

		If  Used("cur_test")
			Use In "cur_test"
		Endif
		Select 0
		Create Cursor cur_test (numdoc c(8),dtmovim d(10),idmovim c(2),vlmovim N(12,2))
		i2=1
		For i = 1 To 50
			If  i<26
				m.idmovim="01"  && forecast movement
				i2=i2+1
			Else
				m.idmovim="02"  && payment movement
				i2=i2-1
			Endif
			m.numdoc=Transform(i2,"@L 999999")
			m.dtmovim=This.timeline1.dDt_start+i2
			m.vlmovim=110.32
			Insert Into cur_test From Memvar
		Endfor
	Endproc
	Procedure Show
		This.timeline1.setup_timeline()
		ldbase						= Thisform.timeline1.dDt_base
		ldend						= Thisform.timeline1.dDt_end
		ldstart						= Thisform.timeline1.dDt_start
		*SET STEP on
		Dimension asema[7]
		asema[1]					= "Sun"
		asema[2]					= "Mon"
		asema[3]					= "Tue"
		asema[4]					= "Wed"
		asema[5]					= "Thu"
		asema[6]					= "Fry"
		asema[7]					= "Sat"
		Thisform.timeline1.clearall()
		Select cur_test
		Scan 
			If  Inlist(idmovim,"01","02")
			Else
				Loop
			Endif
			lntipo					= Iif(idmovim="01",3,4)
			If  Empty(dtmovim)
				lcday				= ""
			Else
				lcday				= asema[DOW(dtmovim)]+" "+Transform(Day(dtmovim),"@L 99")
			Endif
			lcdescri = Iif(idmovim="01","Forecast/","Payment/")+lcday+"/"+Alltrim(numdoc)+"/"+Transform(vlmovim,"9999,999,999.99")+Chr(13)
			lnvlverde=vlmovim
			lnvlverme=0
			lnvlbase=0
			This.timeline1.event_insert(lntipo, dtmovim, lnvlverde, lnvlverme, lnvlbase, lcdescri)
			lccab					= ""
		Endscan
	Endproc
Enddefine


Define Class month As Container
	Width = 107
	Height = 147
	BorderWidth = 0
	BackColor = Rgb(221,221,221)
	ntipo = 0
	Name = "month"
	*\
	*\ Member Object Label1
	*\
	Add Object  Label1 As Label With;
		AutoSize = .T.,;
		FontBold = .T.,;
		FontSize = 8,;
		BackStyle = 0,;
		Caption = "Label1",;
		Height = 16,;
		Left = 7,;
		Top = 128,;
		Width = 38,;
		ForeColor = Rgb(197,188,203),;
		Name = "Label1"

	*\
	*\ Member Object Line1
	*\
	Add Object  Line1 As Line With;
		BorderWidth = 1,;
		Height = 28,;
		Left = 0,;
		Top = 118,;
		Width = 0,;
		BorderColor = Rgb(180,170,188),;
		Name = "Line1"

	*\
	*\ Member Object Line2
	*\
	Add Object  Line2 As Line With;
		Height = 0,;
		Left= (-2),;
		Top = 118,;
		Width = 130,;
		BorderColor = Rgb(202,197,207),;
		Name = "Line2"

	Procedure Init()
		This.ntipo						= Iif(Type("this.parent.ntipo")="N",This.Parent.ntipo,2)
	Endproc

Enddefine &&month


Define Class messages As Form
	Top = 0
	Left = 0
	Height = 120
	Width = 230
	Desktop = .T.
	ShowWindow = 2
	DoCreate = .T.
	BorderStyle = 1
	Caption = ""
	ControlBox = .F.
	Closable = .F.
	MaxButton = .F.
	MinButton = .F.
	Movable = .F.
	TabStop = .F.
	TitleBar = 0
	AlwaysOnTop = .T.
	BackColor = Rgb(255,255,193)
	oparent= ""
	Name = "messages"
	*\
	*\ Member Object Timer1
	*\
	Add Object  Timer1 As Timer With;
		Top = 28,;
		Left = 286,;
		Height = 23,;
		Width = 23,;
		Enabled = .F.,;
		Interval = 10000,;
		Name = "Timer1"

	Procedure Timer1.Timer()
		This.Enabled=.F.
		Thisform.Visible=.F.
	Endproc

	*\
	*\ Member Object List1
	*\
	Add Object  List1 As ListBox With;
		FontSize = 7,;
		ColumnCount = 4,;
		ColumnWidths = "45,30,60,80",;
		Height = 85,;
		ColumnLines = .F.,;
		IncrementalSearch = .F.,;
		Left = 0,;
		SpecialEffect = 1,;
		TabStop = .F.,;
		Top = 15,;
		Width = 230,;
		ItemForeColor = Rgb(193,97,0),;
		ItemBackColor = Rgb(255,255,179),;
		SelectedItemForeColor = Rgb(255,128,64),;
		SelectedItemBackColor = Rgb(255,255,128),;
		BorderColor = Rgb(255,255,198),;
		Themonth = .F.,;
		AutoHideScrollbar = 1,;
		Name = "List1"

	Procedure List1.MouseMove()
		Lparameters nButton, nShift, nXCoord, nYCoord
		Thisform.Timer1.Reset
	Endproc

	Procedure List1.KeyPress()
		Lparameters nKeyCode, nShiftAltCtrl
		Thisform.Timer1.Reset
	Endproc

	*\
	*\ Member Object Label1
	*\
	Add Object  Label1 As Label With;
		BackStyle = 0,;
		Caption = "Tipo",;
		Height = 17,;
		Left = 4,;
		Top= (-1),;
		Width = 40,;
		ForeColor = Rgb(255,128,0),;
		Name = "Label1"

	*\
	*\ Member Object Label2
	*\
	Add Object  Label2 As Label With;
		BackStyle = 0,;
		Caption = "Num.doc.",;
		Height = 17,;
		Left = 79,;
		Top= (-1),;
		Width = 55,;
		ForeColor = Rgb(255,128,0),;
		Name = "Label2"

	*\
	*\ Member Object Label3
	*\
	Add Object  Label3 As Label With;
		BackStyle = 0,;
		Caption = "Value",;
		Height = 17,;
		Left = 167,;
		Top= (-1),;
		Width = 31,;
		ForeColor = Rgb(255,128,0),;
		Name = "Label3"

	*\
	*\ Member Object Line1
	*\
	Add Object  Line1 As Line With;
		Height = 0,;
		Left= (-1),;
		Top = 13,;
		Width = 47,;
		BorderColor = Rgb(255,128,0),;
		Name = "Line1"

	*\
	*\ Member Object Line2
	*\
	Add Object  Line2 As Line With;
		Height = 0,;
		Left = 80,;
		Top = 13,;
		Width = 55,;
		BorderColor = Rgb(255,128,0),;
		Name = "Line2"

	*\
	*\ Member Object Line3
	*\
	Add Object  Line3 As Line With;
		Height = 0,;
		Left = 145,;
		Top = 13,;
		Width = 56,;
		BorderColor = Rgb(255,128,0),;
		Name = "Line3"

	*\
	*\ Member Object Line4
	*\
	Add Object  Line4 As Line With;
		Height = 0,;
		Left= (-3),;
		Top = 101,;
		Width = 47,;
		BorderColor = Rgb(255,128,0),;
		Name = "Line4"

	*\
	*\ Member Object Line5
	*\
	Add Object  Line5 As Line With;
		Height = 0,;
		Left = 80,;
		Top = 101,;
		Width = 55,;
		BorderColor = Rgb(255,128,0),;
		Name = "Line5"

	*\
	*\ Member Object Line6
	*\
	Add Object  Line6 As Line With;
		Height = 0,;
		Left = 145,;
		Top = 101,;
		Width = 56,;
		BorderColor = Rgb(255,128,0),;
		Name = "Line6"

	*\
	*\ Member Object lbltotal
	*\
	Add Object  lbltotal As Label With;
		FontBold = .T.,;
		FontSize = 7,;
		Alignment = 1,;
		BackStyle = 0,;
		Caption = "Value",;
		Height = 12,;
		Left = 141,;
		Top = 103,;
		Width = 57,;
		ForeColor = Rgb(255,128,0),;
		Name = "lbltotal"

	Procedure Init()
		Declare SetWindowLong In Win32Api As _Sol_SetWindowLong Integer, Integer, Integer
		Declare SetLayeredWindowAttributes In Win32Api As _Sol_SetLayeredWindowAttributes Integer, String, Integer, Integer
	Endproc

	Procedure Deactivate()
		This.Visible					 = .F.
		Thisform.oparent.listipwindow=.F.
	Endproc

	Procedure Show()
		Lparameters nStyle
		#Define BADOS_LOC	"Is available for XP or beyond"
		If Val(Os(3))<5
			messagebox(BADOS_LOC)
			Return .F.
		Endif
		_Sol_SetWindowLong(Thisform.HWnd, -20, 0x00080000)
		_Sol_SetLayeredWindowAttributes(Thisform.HWnd, 0, 200, 2)
	Endproc

Enddefine &&messages


Define Class semana As Container
	Width = 38
	Height = 118
	BorderWidth = 0
	BackColor = Rgb(238,238,238)
	lbinddone = .F.
	ntipo = 0
	ntotal = 0
	Name = "semana"
	*\
	*\ Member Object Shape1
	*\
	Add Object  Shape1 As Shape With;
		Top = 28,;
		Left = 4,;
		Height = 67,;
		Width = 14,;
		BorderStyle = 0,;
		Visible = .F.,;
		BackColor = Rgb(204,157,149),;
		Name = "Shape1"

	Procedure Shape1.Click()
		This.Parent.show_message(This.cmessage,This.ntotal)
	Endproc

	Procedure Shape1.Init()
		This.AddProperty("cmessage","")
		This.AddProperty("ntotal",0)
		This.AddProperty("ncntpass",0)
	Endproc

	*\
	*\ Member Object Label1
	*\
	Add Object  Label1 As Label With;
		FontSize = 7,;
		WordWrap = .T.,;
		Alignment = 1,;
		BackStyle = 0,;
		Caption = "Label1",;
		Height = 18,;
		Left = 2,;
		Top = 100,;
		Width = 33,;
		ForeColor = Rgb(183,170,195),;
		Name = "Label1"

	*\
	*\ Member Object Line1
	*\
	Add Object  Line1 As Line With;
		Height = 126,;
		Left = 37,;
		Top = 0,;
		Width = 0,;
		BorderColor = Rgb(221,221,221),;
		Name = "Line1"

	*\
	*\ Member Object Shape2
	*\
	Add Object  Shape2 As Shape With;
		Top= (-1),;
		Left = 20,;
		Height = 96,;
		Width = 14,;
		BorderStyle = 0,;
		Visible = .F.,;
		BackColor = Rgb(176,208,182),;
		Name = "Shape2"

	Procedure Shape2.Click()
		This.Parent.show_message(This.cmessage,This.ntotal)
	Endproc

	Procedure Shape2.Init()
		This.AddProperty("cmessage","")
		This.AddProperty("ntotal",0)
		This.AddProperty("ncntpass",0)
	Endproc

	*\
	*\ Member Object Image1
	*\
*	Add Object  Image1 As Image With;
*		Picture= "..\galeria\png\01.png",
	Add Object  Image1 As Shape With;
		Height = 10,;
		Left = 10,;
		Top = 17,;
		Visible = .F.,;
		Width = 10,;
		backcolor=RGB(255,0,0),;
		curvature=50,;
		Name = "Image1"

	Procedure Image1.Click()
		This.Parent.show_message(This.cmessage,This.ntotal)
	Endproc

	Procedure Image1.Init()
		This.AddProperty("cmessage","")
		This.AddProperty("ntotal",0)
		This.AddProperty("ncntpass",0)
	Endproc

	*\
	*\ Member Object Image2
	*\
*	Add Object  Image2 As Image With;
*		Picture= "..\galeria\png\02.png",
	Add Object  Image2 As Shape With;
		Height = 10,;
		Left = 10,;
		Top = 45,;
		Visible = .F.,;
		Width = 10,;
		backcolor=RGB(0,255,0),;
		curvature=50,;
		Name = "Image2"

	Procedure Image2.Click()
		This.Parent.show_message(This.cmessage,This.ntotal)
	Endproc

	Procedure Image2.Init()
		This.AddProperty("cmessage","")
		This.AddProperty("ntotal",0)
		This.AddProperty("ncntpass",0)
	Endproc

	*\
	*\ Member Object Image3
	*\
*	Add Object  Image3 As Image With;
*		Picture= "..\galeria\png\03.png",
	Add Object  Image3 As Shape With;
		Height = 10,;
		Left = 10,;
		Top = 60,;
		Visible = .F.,;
		Width = 10,;
		backcolor=RGB(0,128,192),;
		curvature=50,;
		Name = "Image3"

	Procedure Image3.Click()
		This.Parent.show_message(This.cmessage,This.ntotal)
	Endproc

	Procedure Image3.Init()
		This.AddProperty("cmessage","")
		This.AddProperty("ntotal",0)
		This.AddProperty("ncntpass",0)
	Endproc

	*\
	*\ Member Object Image4
	*\
*	Add Object  Image4 As Image With;
*		Picture= "..\galeria\png\07.png",
	Add Object  Image4 As Shape With;
		Height = 10,;
		Left = 10,;
		Top = 31,;
		Visible = .F.,;
		Width = 10,;
		backcolor=RGB(255,0,255),;
		curvature=50,;
		Name = "Image4"

	Procedure Image4.Click()
		This.Parent.show_message(This.cmessage,This.ntotal)
	Endproc

	Procedure Image4.Init()
		This.AddProperty("cmessage","")
		This.AddProperty("ntotal",0)
		This.AddProperty("ncntpass",0)
	Endproc

	Procedure show_message()
		Lparameters pcMessage, pntotal
		Thisform.omessages.List1.Clear()
		Do While .T.
			If  Empty(pcMessage)
				Exit
			Endif
			lnpos=At(Chr(13),pcMessage)
			If  lnpos>0
				pcMsg			= Substr(pcMessage,1,lnpos-1)
				pcMessage		= Stuff(pcMessage,1,lnpos,"")
			Else
				Exit
			Endif
			lnpos=At("/",pcMsg)
			If  lnpos>0
				lctype=Substr(pcMsg,1,lnpos-1)
				pcMsg=Stuff(pcMsg,1,lnpos,"")
			Else
				lctype=""
			Endif
			lnpos=At("/",pcMsg)
			If  lnpos>0
				lcday=Substr(pcMsg,1,lnpos-1)
				pcMsg=Stuff(pcMsg,1,lnpos,"")
			Else
				lcday=""
			Endif
			lnpos=At("/",pcMsg)
			If  lnpos>0
				lcdoc=Substr(pcMsg,1,lnpos-1)
				pcMsg=Stuff(pcMsg,1,lnpos,"")
			Else
				lcdoc=""
			Endif
			lcval=pcMsg
			Thisform.listipwindow=.T.
			With Thisform.omessages
				.Top						= Mrow(_Screen.Name,3)-(.Height/3)+10
				.Left						= Mcol(_Screen.Name,3)-(.Width/2)
				.List1.AddItem(lctype)
				.List1.ListItem(.List1.ListCount,2)=lcday
				.List1.ListItem(.List1.ListCount,3)=lcdoc
				.List1.ListItem(.List1.ListCount,4)=lcval
				.Timer1.Enabled				= .T.
				.Visible					= .T.
			Endwith
		Enddo
		Thisform.omessages.lbltotal.Caption=Transform(pntotal,"9999,999,999.99")
	Endproc

	Procedure Init()
		This.ntipo						= Iif(Type("this.parent.ntipo")="N",This.Parent.ntipo,2)
	Endproc

Enddefine &&semana


Define Class timeline As Container
	Width = 586
	Height = 150
	SpecialEffect = 1
	MousePointer = 9
	BackColor = Rgb(238,238,238)
	dDt_start = ({})
	dDt_end = ({})
	dDt_base = ({})
	ntipo = 2
	Name = "timeline"
	*\
	*\ Member Object otimeline
	*\
	Add Object  otimeline As Container With;
		Top = 2,;
		Left = 2,;
		Width = 293,;
		Height = 148,;
		BackStyle = 0,;
		BorderWidth = 0,;
		MousePointer = 9,;
		Name = "otimeline"

	Procedure otimeline.Init()
		Thisform.AddProperty("omessages",Newobject("messages"))
		Thisform.omessages.oparent=Thisform
		This.AddProperty("perae",.F.)
		This.AddProperty("Moving",.F.)
		This.AddProperty("Starting", Null)
		This.AddProperty("RestrictHorizontal",.F.)
		This.AddProperty("RestrictVertical",.T.)
		This.Starting			= Createobject('Empty')
		AddProperty(This.Starting, 'X', Null)
		AddProperty(This.Starting, 'Y', Null)
		AddProperty(This.Starting, 'Left', Null)
		AddProperty(This.Starting, 'Top', Null)
	Endproc

	Procedure otimeline.MouseDown()
		Lparameters nButton, nShift, nXCoord, nYCoord
		*thisform.listipwindow=.t.
		If nButton = 1
			This.Moving			= .T.
			This.Starting.Left	= This.Left
			This.Starting.Top	= This.Top
			This.Starting.X		= nXCoord
			This.Starting.Y		= nYCoord
		Endif
		*If nButton = 4
		*	This.Moving			= !This.Moving
		*	IF  This.Moving
		*		SYS(2060 , 0)
		*	ELSE
		*		SYS(2060 , 1)
		*	endif
		*	This.Starting.Left	= This.Left
		*	This.Starting.Top	= This.Top
		*	This.Starting.X		= nXCoord
		*	This.Starting.Y		= nYCoord
		*Endif
	Endproc

	Procedure otimeline.MouseMove()
		Lparameters nButton, nShift, nXCoord, nYCoord
		*IF  this.perae
		*	RETURN
		*ENDIF
		*this.perae=.t.
		If This.Moving
			lnMinPos             = (This.Parent.Width-This.Width-9)
			lnMaxPos             = 3
			lnpos				 = This.Starting.Left + Iif(This.RestrictHorizontal, 0, (nXCoord - This.Starting.X))
			lnindex				 = 1
			If  This.Starting.Y>130
				lnindex			 = 4
				lnpos			 = This.Starting.Left + Iif(This.RestrictHorizontal, 0, (nXCoord - This.Starting.X)*lnindex)
			Endif
			If  lnpos < lnMinPos
				Return
			Else
				If  lnpos > lnMaxPos
					Return
				Endif
			Endif
			This.Left			= This.Starting.Left + Iif(This.RestrictHorizontal, 0, (nXCoord - This.Starting.X)*lnindex)
			This.Top			= This.Starting.Top + Iif(This.RestrictVertical, 0, (nYCoord - This.Starting.Y))
		Endif
		*this.perae=.f.
	Endproc

	Procedure otimeline.MouseUp()
		Lparameters nButton, nShift, nXCoord, nYCoord
		If nButton = 1
			This.Moving		= .F.
		Endif
	Endproc

	*\
	*\ Member Object lente
	*\
	Add Object  lente As Shape With;
		Top = 97,;
		Left = 271,;
		Height = 53,;
		Width = 44,;
		BorderStyle = 6,;
		DrawMode = 5,;
		Name = "lente"

	Procedure setup_timeline()
		Dimension lamonthes[12]
		lamonthes[01]						= "Jan"
		lamonthes[02]						= "Feb"
		lamonthes[03]						= "Mar"
		lamonthes[04]						= "Apr"
		lamonthes[05]						= "May"
		lamonthes[06]						= "Jun"
		lamonthes[07]						= "Jul"
		lamonthes[08]						= "Ago"
		lamonthes[09]						= "Sep"
		lamonthes[10]						= "Oct"
		lamonthes[11]						= "Nov"
		lamonthes[12]						= "Dec"
		If  Amembers(laMembers, This.otimeline, 2) > 0
			loObj			= This.otimeline
			For Each lcMember In laMembers
				o = loObj.&lcMember
				If  Type("o.name")="C" .And. Type("o.baseclass")="C"
					If  o.BaseClass<>"Container"
						Loop
					Endif
					loObj				 = o
					This.otimeline.RemoveObject(o.Name)
				Endif
			Endfor
		Endif
		*** 
		**
		lddtfim							= This.dDt_end+7
		Do While Dow(lddtfim)<>7
			lddtfim=lddtfim+1
		Enddo
		*** 
		**
		lddtini							= This.dDt_start-7
		lddtbase						= This.dDt_base
		Do While Dow(lddtini)<>1
			lddtini=lddtini-1
		Enddo
		*** 
		lnoldmonth						= 0
		lnoldano						= 0
		lnoldsem						= 0
		lotimeline					= This.otimeline
		With lotimeline
			.Visible			= .T.
		Endwith
		lldone				= .F.
		Do While lddtini =< lddtfim
			lnmonth=Month(lddtini)
			lnano=Year(lddtini)
			lnddsem=Dow(lddtini)
			If  lnoldmonth = lnmonth
			Else
				If  Type("lomonth.name")="C"
					lcweek2			= This.WeekOfMonth(lddtini)
					lcweek			= Transform(Week(lddtini),"@L 999")
					lnpos			= This.setupandposit(lomonth)
					lomonth.Width		= lnpos
					lomonth.Line2.Width = lomonth.Width+4
					lomonth.Visible	= .T.
					lldone		= .T.
				Endif
				lnmaiorano		    = Year(This.ThisSaturday(lddtini))
				lcper				= Transform(lnmonth,"@L 99")+Transform(lnmaiorano,"@L 9999")
				If  lddtini<lddtbase
					lcprefix="A"
				Else
					lcprefix="D"
				Endif
				lotimeline.Newobject(lcprefix+"month"+lcper,"month")
				lomonth				= Evaluate("lotimeline."+lcprefix+"month"+lcper)
				Bindevent(lomonth,"MouseDown",This.otimeline,"MouseDown")
				Bindevent(lomonth,"MouseUp",This.otimeline,"MouseUp")
				Bindevent(lomonth,"MouseMove",This.otimeline,"MouseMove")
				lomonth.MousePointer=9
				lcdescr				 = lamonthes[lnmonth]+" / "+ Transform(lnano,"@L 9999")
				lomonth.Label1.Caption=lcdescr
				lomonth.AddProperty("nSemanaI",Week(lddtini,2))
				lomonth.AddProperty("nSemanaF",Week(lddtini,2))
				lnddsem=1
			Endif
			If  lnddsem=1
				lnmaiordia		    = This.ThisSaturday(lddtini)
				lnmenordia			= lddtini
				llnnxtmon			= Month(lnmenordia)
				lcweek2				= This.WeekOfMonth(lnmenordia)
				lnano				= Year(lnmenordia)
				lnmonth				= Month(lnmenordia)
				lcweek				= Transform(Week(lnmenordia,1),"@L 999")
				If  lnoldano = lnano
				Else
					lcweek			= Transform(Week(lnmenordia),"@L 999")
				Endif
				If lcweek = "001" And lnmonth = 12
					lnWeek = Week(lnmenordia-7,1) + 1
					lcweek			= Transform(lnWeek,"@L 999")
				Endif
				lcper				= Transform(lnmonth,"@L 99")+Transform(lnano,"@L 9999")+lcweek
				lomonth.Newobject("sem"+Transform(lnano,"@L 9999")+lcweek,"semana")
				losemana			= Evaluate("lomonth."+"sem"+Transform(lnano,"@L 9999")+lcweek)
				losemana.Label1.Caption=lcweek2
				losemana.AddProperty("dDiaI",lnmenordia)
				losemana.AddProperty("dDiaF",lnmaiordia)
				If  This.dDt_end<lnmaiordia
					This.dDt_end=lnmaiordia
				Endif
				If  Week(lddtini,2)>lomonth.nSemanaF
					lomonth.nSemanaF	= Week(lddtini,2)
				Endif
				lldone			= .F.
			Endif
			lddtini  = lddtini + 1
			lnoldmonth = lnmonth
			lnoldano = lnano
			lnoldsem = lnddsem
		Enddo
		If  lldone
		Else
			lnpos			= This.setupandposit(lomonth)
			lomonth.Width		= lnpos
			lomonth.Line2.Width = lomonth.Width+4
			lomonth.Visible	= .T.
			lldone		= .T.
		Endif
		If  Amembers(laMembers2, lotimeline, 2) > 0
			lnpos			= 0
			loObj2			= lotimeline
			For Each lcMember2 In laMembers2
				o = loObj2.&lcMember2
				If  Type("o.name")="C" .And. Type("o.baseclass")="C"
					If  o.BaseClass<>"Container"
						Loop
					Endif
					o.Left  = lnpos
					o.Visible = .T.
					lnpos   = lnpos+o.Width
				Endif
			Endfor
			lotimeline.Width = lnpos
			lotimeline.Left = ((lotimeline.Width-This.Width)/2)*(-1)
			This.lente.ZOrder(0)
		Endif
		lotimeline.Starting.Left	= lotimeline.Left
		lotimeline.Starting.Top	= lotimeline.Top
		lotimeline.Starting.X		= lotimeline.Left
		lotimeline.Starting.Y		= lotimeline.Top
	Endproc

	Procedure WeekOfMonth()
		Lparameters m.date2
		Private m.date2,i,m.factor,dd1,dd2,lcdd
		dd1=This.ThisSunDay(m.date2)
		lcdd=Transform(Day(dd1))
		dd2=This.ThisSaturday(m.date2)
		If  dd1=dd2
			lcdd="day "+lcdd
		Else
			lcdd=lcdd+" - "+Transform(Day(dd2))
		Endif
		Return lcdd
	Endproc

	Procedure ThisSaturday()
		Lparameters m.date
		Private m.date,lnoldmonth,llcontinua
		lnoldmonth						= Month(m.date)
		llcontinua						= .T.
		Do While Dow(m.date)<>7 And llcontinua
			lnprxdia					= m.date+1
			If  Month(lnprxdia)<>lnoldmonth
				llcontinua				= .F.
				Loop
			Endif
			m.date						= m.date+1
		Enddo
		Return(m.date)
	Endproc

	Procedure ThisSunDay()
		** this returns the Sunday...
		Lparameters m.date
		Private m.date,i,lnoldmonth,llcontinua
		lnoldmonth=Month(m.date)
		llcontinua						= .T.
		Do While Dow(m.date)<>1 And llcontinua
			If  (Month(m.date-1))<>lnoldmonth
				llcontinua				= .F.
				Loop
			Endif
			m.date=m.date-1
		Enddo
		Return(m.date)
	Endproc

	Procedure setupandposit()
		Lparameters pomonth
		Local lnpos, loObj2, losemana, lomonth, lcweek, lnano, lnocorr
		lnpos			= 0
		loObj2			= pomonth
		If  Amembers(laMembers2, pomonth, 2) > 0
		Else
			Return
		Endif
		If  (pomonth.nSemanaF - pomonth.nSemanaI)>0
		Else
			*	RETURN
		Endif
		= Asort(laMembers2)     && Sort the array
		For Each lcMember2 In laMembers2
			o = loObj2.&lcMember2
			If  Type("o.name")="C" .And. Type("o.baseclass")="C"
				If  o.BaseClass<>"Container"
					Loop
				Endif
				o.Left  = lnpos
				lnpos   = lnpos+o.Width
				If  o.lbinddone
				Else
					o.Visible = .T.
					Bindevent(o,"MouseDown",This.otimeline,"MouseDown")
					Bindevent(o,"MouseUp",This.otimeline,"MouseUp")
					Bindevent(o,"MouseMove",This.otimeline,"MouseMove")
					o.MousePointer=9
					*			Bindevent(o,"MouseDown",This,"mmdownlow")
					o.MousePointer=9
					o.lbinddone=.T.
				Endif
			Endif
		Endfor
		Return lnpos
	Endproc

	Procedure event_insert()
		Lparameters pntipo, pdtmov, pnvlverde, pnvlverme, pnvlbase, pcdescri
		If  pdtmov<This.dDt_base
			lcprefix="A"
		Else
			lcprefix="D"
		Endif
		lnmonth				= Month(pdtmov)
		lnano				= Year(pdtmov)
		lcper				= Transform(lnmonth,"@L 99")+Transform(lnano,"@L 9999")
		If  Type("this.otimeline."+lcprefix+"month"+lcper)<>"O"
			Return
		Endif
		lomonth				= Evaluate("this.otimeline."+lcprefix+"month"+lcper)
		If  Amembers(laMembers2, lomonth, 2) > 0
			lnpos			= 0
			loObj2			= lomonth
			For Each lcMember2 In laMembers2
				o = loObj2.&lcMember2
				If  Type("o.name")="C" .And. Type("o.baseclass")="C"
					If  o.BaseClass<>"Container" .Or. Substr(o.Name,1,3)<>"sem"
						Loop
					Endif
					If  pdtmov >= o.dDiaI .And. pdtmov =< o.dDiaF
						If  o.ntipo=1
						Else
							If  pntipo=1
								o.Image1.cmessage=o.Image1.cmessage+pcdescri
								o.Image1.ntotal=o.Image1.ntotal+pnvlverde
								o.Image1.ncntpass=o.Image1.ncntpass+1
								lccnt=Alltrim(Str(o.Image1.ncntpass))
								o.Image1.ToolTipText=lccnt+" Previsão(ões) (R$"+Alltrim(Transform(o.Image1.ntotal,"9999,999,999.99"))+")"
								o.Image1.Visible=.T.
							Endif
							If  pntipo=2
								o.Image4.cmessage=o.Image4.cmessage+pcdescri
								o.Image4.ntotal=o.Image4.ntotal+pnvlverde
								o.Image4.ncntpass=o.Image4.ncntpass+1
								lccnt=Alltrim(Str(o.Image4.ncntpass))
								o.Image4.ToolTipText=lccnt+" Pagamento(s) (R$"+Alltrim(Transform(o.Image4.ntotal,"9999,999,999.99"))+")"
								o.Image4.Visible=.T.
							Endif
							If  pntipo=3
								o.Image2.cmessage=o.Image2.cmessage+pcdescri
								o.Image2.ntotal=o.Image2.ntotal+pnvlverde
								o.Image2.ncntpass=o.Image2.ncntpass+1
								lccnt=Alltrim(Str(o.Image2.ncntpass))
								o.Image2.ToolTipText=lccnt+" Provisionamento(s) (R$"+Alltrim(Transform(o.Image2.ntotal,"9999,999,999.99"))+")"
								o.Image2.Visible=.T.
							Endif
							If  pntipo=4
								o.Image3.cmessage=o.Image3.cmessage+pcdescri
								o.Image3.ntotal=o.Image3.ntotal+pnvlverde
								o.Image3.ncntpass=o.Image3.ncntpass+1
								lccnt=Alltrim(Str(o.Image3.ncntpass))
								o.Image3.ToolTipText=lccnt+" Pagamento(s) (R$"+Alltrim(Transform(o.Image3.ntotal,"9999,999,999.99"))+")"
								o.Image3.Visible=.T.
							Endif
						Endif
					Endif
				Endif
			Endfor
		Endif
	Endproc

	Procedure clearall()
		loobjx				= This.otimeline
		If  Amembers(laMembers, loobjx, 2) > 0
			For Each lcMember In laMembers
				ox = loobjx.&lcMember
				If  Type("ox.name")="C" .And. Type("ox.baseclass")="C"
					If  ox.BaseClass<>"Container" .Or. Substr(ox.Name,2,3)<>"month"
						Loop
					Endif
					lomonth				= ox
					If  Amembers(laMembers2, lomonth, 2) > 0
						lnpos			= 0
						loObj2			= lomonth
						For Each lcMember2 In laMembers2
							o = loObj2.&lcMember2
							If  Type("o.name")="C" .And. Type("o.baseclass")="C"
								If  o.BaseClass<>"Container" .Or. Substr(o.Name,1,3)<>"sem"
									Loop
								Endif
								If  o.ntipo=1
								Else
									o.Image1.cmessage=""
									o.Image1.ntotal=0
									o.Image1.ToolTipText=""
									o.Image1.ncntpass=0
									o.Image1.Visible=.F.
									o.Image4.cmessage=""
									o.Image4.ntotal=0
									o.Image4.ToolTipText=""
									o.Image4.ncntpass=0
									o.Image4.Visible=.F.
									o.Image2.cmessage=""
									o.Image2.ntotal=0
									o.Image2.ToolTipText=""
									o.Image2.ncntpass=0
									o.Image2.Visible=.F.
									o.Image3.cmessage=""
									o.Image3.ntotal=0
									o.Image3.ToolTipText=""
									o.Image3.ncntpass=0
									o.Image3.Visible=.F.
								Endif
							Endif
						Endfor
					Endif
				Endif
			Endfor
		Endif
	Endproc

Enddefine &&timeline
"Now to him who is able to do immeasurably more than all we ask or imagine, according to his power that is at work within us, Ephesians 3:20
Reply
Map
View

Click here to load this message in the networking platform