Working on VFP objects dynamically - partI

Published on by Yousfi Benameur


Any Control Object can be draggable On Form here If its property DragMode=0 (manually).
Some wanted Controls  are binded To the methods my (As MouseDown) And my1 (As MouseUp).
MouseDown On draggable Control begins the Drag operation And MouseUp Ends it.
Some olecontrols (As monthview,slider) can Drag As well With This method.
Controls With dragmode set To 1 (automaric) are not draggable here.
Object.DragMode=0  (Default) Manual. Requires using the Drag method To initiate dragging Of the Source Control.
Object.dragmode=1   Automatic. Clicking the Source Control automatically initiates dragging.

When DragMode Is Set To 1 (Automatic), the Control does Not respond To Mouse Events,there i Used In This Code To particularize Some Controls As Not draggable.
the code provides  capture manually the custom form surface as  arranged by user.
important note:on a 64 bits system can use this code
RUN /n c:\windows\sysnative\SnippingTool.exe  &&for a windows 64 bits (this is available for all 32 bits win apps on a 64 bits win system)



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


*1* drag controls with mouse on a vfp form 
*the code asks to a form background picture.(updated:picture is linked to web directly.)

set defa to addbs(justpath(sys(16,1)))

publi yform
yform=newObject("ydrag")
yform.show
read events
retu
*
DEFINE CLASS ydrag AS form
Top = -5
Left = -13
Height = 599
Width = 1004
ShowWindow = 2
Caption = ""
BackColor = RGB(0,0,0)
x0 = .F.
y0 = .F.
first = .F.

ADD OBJECT image1 AS image WITH ;
DragMode = 1, ;
Picture = home()+"graphics\metafiles\arrows\2darrow2.wmf", ;
Stretch = 2, ;
BackStyle = 0, ;
BorderStyle = 0, ;
Height = 108, ;
Left = 84, ;
Top = 72, ;
Width = 156, ;
BorderColor = RGB(255,0,0), ;
Name = "Image1"

ADD OBJECT shape1 AS shape WITH ;
DragMode = 1, ;
Top = 48, ;
Left = 324, ;
Height = 108, ;
Width = 109, ;
BorderWidth = 4, ;
Curvature = 25, ;
BackColor = RGB(0,255,0), ;
BorderColor = RGB(255,0,0), ;
Name = "Shape1"

ADD OBJECT command1 AS commandbutton WITH ;
Top = 300, ;
Left = 276, ;
Height = 61, ;
Width = 121, ;
FontBold = .T., ;
FontSize = 11, ;
Caption = "Command1", ;
ForeColor = RGB(0,0,0), ;
BackColor = RGB(128,0,255), ;
Name = "Command1"

ADD OBJECT label1 AS label WITH ;
WordWrap = .T., ;
Caption = "ZEZAEERZ RRERERE SRERERE RERERERERER", ;
Height = 49, ;
Left = 504, ;
Top = 48, ;
Width = 205, ;
ForeColor = RGB(255,0,0), ;
BackColor = RGB(255,255,0), ;
Name = "Label1"

ADD OBJECT line1 AS line WITH ;
BorderWidth = 20, ;
Height = 17, ;
Left = 480, ;
Top = 216, ;
Width = 100, ;
LineSlant = "/", ;
BorderColor = RGB(255,255,0), ;
Name = "Line1"

ADD OBJECT list1 AS listbox WITH ;
ColumnCount = 0, ;
ColumnWidths = "", ;
RowSourceType = 1, ;
FirstElement = 1, ;
Height = 170, ;
Left = 420, ;
Top = 288, ;
Width = 100, ;
Name = "List1"

ADD OBJECT edit1 AS editbox WITH ;
Height = 53, ;
Left = 588, ;
Top = 288, ;
Width = 132, ;
BackColor = RGB(255,255,187), ;
Name = "Edit1"

ADD OBJECT text1 AS textbox WITH ;
Value = "Hello World!", ;
Height = 23, ;
Left = 48, ;
Top = 24, ;
Width = 100, ;
Name = "Text1"

ADD OBJECT grid1 AS grid WITH ;
Height = 168, ;
Left = 60, ;
Top = 384, ;
Width = 320, ;
Name = "Grid1"

ADD OBJECT shape2 AS shape WITH ;
Top = 414, ;
Left = 605, ;
Height = 109, ;
Width = 109, ;
BorderWidth = 10, ;
Curvature = 99, ;
BackColor = RGB(255,128,64), ;
BorderColor = RGB(0,255,0), ;
Name = "Shape2"

ADD OBJECT container1 AS ycont WITH ;
Top = 144, ;
Left = 696, ;
Width = 200, ;
Height = 84, ;
BackStyle = 1, ;
BackColor = RGB(128,255,255), ;
Name = "Container1"

ADD OBJECT olecontrol1 AS olecontrol WITH ;
oleclass="MSComCtl2.MonthView.2",;
Top = 360, ;
Left = 732, ;
Height = 180, ;
Width = 215, ;
Name = "Olecontrol1"

ADD OBJECT optiongroup1 AS optiongroup WITH ;
ButtonCount = 2, ;
Value = 1, ;
Height = 46, ;
Left = 780, ;
Top = 72, ;
Width = 71, ;
BackColor = RGB(255,255,0), ;
Name = "Optiongroup1", ;
Option1.Caption = "Option1", ;
Option1.Value = 1, ;
Option1.Height = 17, ;
Option1.Left = 5, ;
Option1.Top = 5, ;
Option1.Width = 61, ;
Option1.Name = "Option1", ;
Option2.Caption = "Option2", ;
Option2.Height = 17, ;
Option2.Left = 5, ;
Option2.Top = 24, ;
Option2.Width = 61, ;
Option2.Name = "Option2"

ADD OBJECT check1 AS checkbox WITH ;
Top = 24, ;
Left = 204, ;
Height = 17, ;
Width = 60, ;
Alignment = 0, ;
Caption = "Check1", ;
Value = 1, ;
BackColor = RGB(0,255,255), ;
Name = "Check1"

ADD OBJECT combo1 AS combobox WITH ;
Height = 24, ;
Left = 276, ;
Top = 216, ;
Width = 100, ;
Name = "Combo1"

ADD OBJECT image2 AS image WITH ;
Picture =home(1)+"graphics\bitmaps\assorted\beany.bmp", ;
BackStyle = 0, ;
Height = 61, ;
Left = 432, ;
Top = 492, ;
Width = 61, ;
Name = "Image2"

ADD OBJECT olecontrol2 AS olecontrol WITH ;
oleclass="MSComctlLib.Slider.2",;
Top = 204, ;
Left = 60, ;
Height = 36, ;
Width = 120, ;
Name = "Olecontrol2"

ADD OBJECT command3 AS commandbutton WITH ;
Top = 12, ;
Left = 876, ;
Height = 27, ;
Width = 84, ;
FontBold = .T., ;
FontSize = 11, ;
Anchor = 768, ;
Caption = "Capture", ;
MousePointer = 15, ;
BackColor = RGB(0,128,192), ;
Name = "Command3"

ADD OBJECT label2 AS label WITH ;
AutoSize = .T., ;
FontBold = .T., ;
FontSize = 40, ;
BackStyle = 0, ;
Caption = "?", ;
Height = 66, ;
Left = 816, ;
Top = 0, ;
Width = 34, ;
ForeColor = RGB(0,255,0), ;
Name = "Label2"

ADD OBJECT shape3 AS shape WITH ;
Top = 252, ;
Left = 72, ;
Height = 109, ;
Width = 150, ;
BorderWidth = 3, ;
Curvature = 99, ;
BackColor = RGB(128,0,64), ;
BorderColor = RGB(0,255,255), ;
Name = "Shape3"

ADD OBJECT  ycheck AS checkbox with ;
Top = 264,;
Left = 756,;
Height = 27,;	
Width = 193,;
FontBold = .T.,;
AutoSize = .T.,;
Alignment = 0,;
Caption = "Hide /Show image Background",;
Style = 1,;
BackColor = RGB(128,128,255),;
Name = "yCheck"

PROCEDURE ycheck.Click
thisform.yback.visible=!thisform.yback.visible
ENDPROC	

PROCEDURE my
LPARAMETERS nButton, nShift, nXCoord, nYCoord
*--- aevent create an array laEvents
Aevents( myArray, 0)
*--- reference the calling object
loObject = myArray[1]
try
this.mousepointer=15
catch
endtry

if thisform.first=.f.
thisform.x0=nxcoord- loObject.left
thisform.y0=nycoord-loObject.top
thisform.first=.t.
endi
ENDPROC

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

with loObject
.left=nxcoord  -thisform.x0
.top=nycoord   -thisform.y0
try
.mousepointer=0
catch
endtry
thisform.first=.f.
endwith
ENDPROC

PROCEDURE Activate
with thisform
.caption="Mousedown and drag to move draggables controls on the form."
with .olecontrol1
.backcolor=4227327
.Forecolor=16711680
.appearance=0
.borderstyle=0
.monthBackcolor=rgb(225,238,200)
.titleBackcolor=4259584
endwith
.windowstate=2
endwith
ENDPROC

PROCEDURE Init
with thisform
for i=1 to .controlcount
try
if .controls(i).dragmode=0  &&mandatory to drag manualy  control object.only these conrols are concerned.
bindevent(.controls(i),"mousedown",thisform,"my" )
bindevent(.controls(i),"mouseup"  ,thisform,"my1")
endi
catch
endtry
endfor
.first=.f.
.x0=0
.y0=0
.addobject("yback","image")

with .yback
*messagebox("get a form bakground picture",0+32+4096,'',1000)
*.picture=getpict()   && "backg.jpg"
*****************************
*this uses my technic to link a web image without any trace on disc (memory only)
Local loRequest,lcUrl
	m.lcUrl="http://www.liberte-tours.com/images/saharamasive.jpg"  
	m.loRequest = Createobject('MsXml2.XmlHttp')
	m.loRequest.Open("GET",lcUrl,.F.)
	m.loRequest.Send()
	.PictureVal=m.loRequest.ResponseBody
	m.loRequest=Null
  *****************************
.stretch=2
.left=0
.top=0
.width =thisform.width
.height=thisform.height
.anchor  =15
.dragmode=1   && not draggable manually
.zorder(1)
.visible=.t.
endwith

endwith
_screen.windowstate=1

ENDPROC

PROCEDURE Destroy
clea events
ENDPROC

PROCEDURE list1.Init
With Thisform.list1
.RowSource = "1111,2222,3333,4444,5555,6666,7777,8888,9999,10"
.RowSourceType=1
.SelectedItemBackColor=Rgb(70,60,50)
.SelectedItemForeColor=rgb(255,255,255)   &&Rgb(10,191,160)
.SpecialEffect=1
.FontSize=10
.ItemBackColor=Rgb(40,40,40)
.ItemForeColor=Rgb(255,204,153)
.BorderColor=Rgb(235,132,0)
.ItemTips=.T.
.MousePointer=15
Endwith
ENDPROC

PROCEDURE edit1.Init
text to this.value noshow
aeezezez
eezezerdgfhghg
uiuuSRFRTR HYYUYUYUYUYUYUYUYY
ZEZEZEZEZEZ
ENDTEXT
ENDPROC

PROCEDURE grid1.Init
sele * from home(1)+"samples\data\customer" into cursor ycurs
with this
.recordsource="ycurs"
.deletemark=.f.
.gridlines=0
.forecolor=255
.fontbold=.t.
.SetAll("DynamicBackColor","IIF(MOD(recno(), 2)=0, RGB(75,55,25) , rgb(20,255,40))" , "Column")
.SetAll("DynamicForecolor","IIF(MOD(recno(), 2)=0, 255 , rgb(255,0,255))" , "Column")
locate
endwith
ENDPROC

PROCEDURE combo1.Init
WITH THIS
.Additem("1.")
.Additem("2.")
.Additem("3.")
.Additem("4.")
.listindex=1
.value=1
style=2
endwith
ENDPROC

PROCEDURE command3.Click
nodefault
run/n snippingtool.exe
ENDPROC

PROCEDURE label2.Click
local m.myvar
text to m.myvar noshow
Any Control Object can be draggable On Form here If its property DragMode=0 (manually).
Some wanted Controls  are binded To the methods my (As MouseDown) And my1 (As MouseUp).
MouseDown On draggable Control begins the Drag operation And MouseUp Ends it.
Some olecontrols (As monthview,slider) can Drag As well With This method.
Controls With dragmodset To 1 (automaric) are nor draggable here.
Object.DragMode=0  (Default) Manual. Requires using the Drag method To initiate dragging Of the Source Control.
Object.dragomde=1   Automatic. Clicking the Source Control automatically initiates dragging.

When DragMode Is Set To 1 (Automatic), the Control does Not respond To Mouse Events,there i Used In This Code To
particularize Some Controls As Not draggable.
can capture manually the custom form surface as  arranged .
endtext
messagebox(m.myvar,0+32)
ENDPROC


ENDDEFINE
*
*-- EndDefine: ydrag
DEFINE CLASS ycont AS container
Top = 144
Left = 696
Width = 200
Height = 84
BackStyle = 1
BackColor = RGB(128,255,255)
Name = "Container1"


ADD OBJECT check1 AS checkbox WITH ;
Top = 12, ;
Left = 12, ;
Height = 17, ;
Width = 60, ;
Alignment = 0, ;
Caption = "Check1", ;
Name = "Check1"


ADD OBJECT commandgroup1 AS commandgroup WITH ;
ButtonCount = 2, ;
BackStyle = 0, ;
Value = 1, ;
Height = 66, ;
Left = 96, ;
Top = 12, ;
Width = 94, ;
Name = "Commandgroup1", ;
Command1.Top = 5, ;
Command1.Left = 5, ;
Command1.Height = 27, ;
Command1.Width = 84, ;
Command1.Caption = "Command1", ;
Command1.Name = "Command1", ;
Command2.Top = 34, ;
Command2.Left = 5, ;
Command2.Height = 27, ;
Command2.Width = 84, ;
Command2.Caption = "Command2", ;
Command2.Name = "Command2"


ADD OBJECT shape1 AS shape WITH ;
Top = 44, ;
Left = 12, ;
Height = 24, ;
Width = 48, ;
Curvature = 60, ;
BackColor = RGB(128,0,255), ;
BorderColor = RGB(255,0,0), ;
Name = "Shape1"


ENDDEFINE
*-- EndDefine: ycont


can arrange controls with a background image and capture the whole screen with snippingtool.note only objects with dragmode=1 can be draggable.
can arrange controls with a background image and capture the whole screen with snippingtool.note only objects with dragmode=1 can be draggable.
can arrange controls with a background image and capture the whole screen with snippingtool.note only objects with dragmode=1 can be draggable.

can arrange controls with a background image and capture the whole screen with snippingtool.note only objects with dragmode=1 can be draggable.

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


*2* resizing vfp controls dynamically (width-height)

publi oform
oform=newObject("yresize")
oform.show
read events
retu
*
DEFINE CLASS yresize AS form
Height = 529
Width = 905
ShowWindow = 2
AutoCenter = .T.
Caption = "Resize vfp  controls  dynamically at right border or bottom border."
BackColor = RGB(212,210,208)
ocap = .F.
ocap1 = .F.
delta = 15
Name = "Form1"

ADD OBJECT shape1 AS shape WITH ;
Top = 144, ;
Left = 84, ;
Height = 168, ;
Width = 228, ;
BorderWidth = 3, ;
Curvature = 30, ;
BackColor = RGB(0,255,255), ;
BorderColor = RGB(255,128,64), ;
Name = "Shape1"

ADD OBJECT image1 AS image WITH ;
Picture = home(1)+"graphics\metafiles\business\apptbook.wmf", ;
Stretch = 2, ;
Height = 380, ;
Left = 456, ;
Top = 108, ;
Width = 400, ;
Name = "Image1"

ADD OBJECT label1 AS label WITH ;
AutoSize = .f.,;
FontSize = 11, ;
WordWrap = .T., ;
BackStyle = 1, ;
Caption = "Having the cursor hand:Click on any control  right border or bottom border to increase (width-height) ----rightclick to decrease", ;
Height = 74, ;
Left = 12, ;
Top = 12, ;
Width = 226, ;
ForeColor = RGB(255,0,0), ;
BackColor = RGB(255,255,128), ;
Name = "Label1"

ADD OBJECT command1 AS commandbutton WITH ;
Top = 348, ;
Left = 144, ;
Height = 48, ;
Width = 96, ;
FontSize = 12, ;
Caption = "Command1", ;
ForeColor = RGB(128,0,255), ;
BackColor = RGB(128,255,0), ;
Name = "Command1"

ADD OBJECT label2 AS label WITH ;
AutoSize = .T., ;
FontBold = .T., ;
FontSize = 40, ;
BackStyle = 0, ;
Caption = "?", ;
Height = 66, ;
Left = 852, ;
Top = 0, ;
Width = 34, ;
ForeColor = RGB(128,0,64), ;
Name = "Label2"

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

do case
case between(nxcoord,loObject.left+loObject.width-thisform.delta,loObject.left+loObject.width)
thisform.ocap=.t.
loObject.mousepointer=15

case between(nycoord,loObject.top+loObject.height-thisform.delta,loObject.top+loObject.height)
thisform.ocap1=.t.
loObject.mousepointer=15

otherwise

thisform.ocap=.f.
thisform.ocap1=.f.
loObject.mousepointer=0
endcase

ENDPROC

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

local m.delta
m.delta=thisform.delta

try
do case

case nbutton=1 and thisform.ocap=.t.
loObject.width=loObject.width+m.delta

case nbutton=2 and thisform.ocap=.t.
loObject.width=loObject.width-m.delta

endcase
catch
endtry

try
do case

case nbutton=1 and thisform.ocap1=.t.
loObject.height=loObject.height+m.delta

case nbutton=2 and thisform.ocap1=.t.
loObject.height=loObject.height-m.delta

endcase
catch
endtry
ENDPROC

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

do case
case thisform.ocap=.t.
thisform.ocap=.f.
case thisform.ocap1=.t.
thisform.ocap1=.f.
endcase

thisform.mousepointer=0

ENDPROC

PROCEDURE Destroy
clea events
ENDPROC

PROCEDURE MouseMove
LPARAMETERS nButton, nShift, nXCoord, nYCoord
this.mousepointer=0
ENDPROC

PROCEDURE Init
thisform.delta=15

with thisform
for i=1 to .controlcount
try
bindevent(.controls(i),"mousemove",thisform,"my")
bindevent(.controls(i),"mousedown",thisform,"my1")
bindevent(.controls(i),"mouseup",thisform,"my2")
catch
endtry
endfor
endwith
ENDPROC


PROCEDURE shape1.MouseUp
LPARAMETERS nButton, nShift, nXCoord, nYCoord
ENDPROC

PROCEDURE label2.Click
local m.myvar
text to m.myvar noshow
this basic code use binbdevent of all vfp controls on the form to permit to resize them dynamically
(as we do at form design time).
it uses the mousedown (method binded to my)
the mouseup (binded to my1)
the mousemove (binded to my)
controls are binded on form.init
the cursor gives the hand to resize when its on the right border or bottom border of the controle.
i used 15px to increase or decrease the width or height of the pointed control.
simple click on right border :increase of 15px the width
simple rightclick on the right border decrease the width with 15px
operation is the same with the bottom of control.

endtext
messagebox(m.myvar,0+32)
ENDPROC

procedure image1.mouseEnter
LPARAMETERS nButton, nShift, nXCoord, nYCoord
this.borderstyle=1
endproc

procedure image1.mouseLeave
LPARAMETERS nButton, nShift, nXCoord, nYCoord
this.borderstyle=0
endproc

ENDDEFINE
*
*-- EndDefine: yresize


Working on VFP objects dynamically - partI

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

*3*
*this code shows how to work with special controls as optionGroup & CommandGroup.
*there can have native vertical disposition or horizontal one.
*these 2 arrangements can done with rightclick (design time) on the control and can choose the wizard...
*can be usefull to create buttons menus....


Publi yform
yform=Newobject("ybuttons")
yform.Show
Read Events
Retu
*
Define Class ybuttons As Form
	Height = 494
	Width = 989
	ShowWindow = 2
	AutoCenter = .T.
	Caption = "CommandGroups & OptionGroup"
	BackColor = Rgb(64,64,64)
	Name = "Form1"

	Add Object command1 As CommandButton With ;
		Top = 10, ;
		Left = 12, ;
		Height = 27, ;
		Width = 96, ;
		FontBold = .T., ;
		Caption = "Optiongroup H", ;
		Name = "Command1"

	Add Object command2 As CommandButton With ;
		Top = 82, ;
		Left = 15, ;
		Height = 27, ;
		Width = 93, ;
		FontBold = .T., ;
		Caption = "OptionGroup V", ;
		Name = "Command2"

	Add Object command3 As CommandButton With ;
		Top = 372, ;
		Left = 0, ;
		Height = 27, ;
		Width = 120, ;
		FontBold = .T., ;
		Caption = "Commandgroup H", ;
		Name = "Command3"

	Add Object command4 As CommandButton With ;
		Top = 60, ;
		Left = 516, ;
		Height = 27, ;
		Width = 120, ;
		FontBold = .T., ;
		Caption = "Commandgroup V", ;
		Name = "Command4"

	Add Object command5 As CommandButton With ;
		Top = 12, ;
		Left = 912, ;
		Height = 37, ;
		Width = 73, ;
		FontBold = .T., ;
		Caption = "Rebuild all", ;
		BackColor = Rgb(128,255,0), ;
		Name = "Command5"

	Add Object label1 As Label With ;
		AutoSize = .T., ;
		FontBold = .T., ;
		FontSize = 10, ;
		Caption = "For these 2 controls there is a  control assist wizard where can choose Horizontal position or vertical.", ;
		Height = 18, ;
		Left = 123, ;
		Top = 456, ;
		Width = 633, ;
		ForeColor = Rgb(128,0,64), ;
		BackColor = Rgb(255,255,128), ;
		Name = "Label1"

	Procedure Destroy
		Clea Events
	Endproc

	Procedure Activate
		With Thisform
			.command1.Click
			.command2.Click
			.command3.Click
			.command4.Click
		Endwith
	Endproc

	Procedure command1.Click
		Local m.delta
		m.delta=5
		Rand(-1)
		With Thisform
			Try
				.AddObject("optionGroup1","optionGroup")
			Catch
			Endtry

			With Thisform.optiongroup1
				.Top=10
				.Left=120
				.ButtonCount=10
				For i=1 To .ButtonCount
					With .Buttons(i)
						.AutoSize=.T.
						.SpecialEffect=2
						.FontBold=.T.
						.ForeColor=Rgb(255*Rand(),255*Rand(),255*Rand())
						.Top=5
						If i=1
							.Left=10
						Else
							.Left=.Parent.Buttons(i-1).Left+.Parent.Buttons(i-1).Width+m.delta
						Endi
						.BackStyle=0
						.MousePointer=15
					Endwith
				Endfor
				.AutoSize=.T.
				.BackStyle=0
				.Visible=.T.
			Endwith
		Endwith
	Endproc


	Procedure command2.Click
		Local m.delta
		m.delta=5
		Rand(-1)
		With Thisform
			Try
				.AddObject("optionGroup2","optionGroup")
			Catch
			Endtry
			With Thisform.optiongroup2
				.Top=This.Top
				.Left=120
				.ButtonCount=10
				For i=1 To .ButtonCount
					With .Buttons(i)
						.AutoSize=.T.
						.SpecialEffect=2
						.ForeColor=Rgb(255*Rand(),255*Rand(),255*Rand())
						.FontBold=.T.
						.BackStyle=0
						.MousePointer=15
					Endwith
				Endfor
				.AutoSize=.T.
				.BackStyle=0
				.Visible=.T.
			Endwith
		Endwith
	Endproc

	Procedure command3.Click
		Local m.delta
		m.delta=5
		Rand(-1)
		With Thisform
			Try
				.AddObject("commandGroup1","commandGroup")
			Catch
			Endtry
			With Thisform.commandgroup1
				.Top=This.Top+This.Height+5
				.Left=10
				.ButtonCount=10
				For i=1 To .ButtonCount
					With .Buttons(i)
						.AutoSize=.T.
						.SpecialEffect=2
						.ForeColor=Rgb(255*Rand(),255*Rand(),255*Rand())
						.FontBold=.T.
						.Top=5
						If i=1
							.Left=10
						Else
							.Left=.Parent.Buttons(i-1).Left+.Parent.Buttons(i-1).Width+m.delta
						Endi
						.MousePointer=15
					Endwith
				Endfor
				.AutoSize=.T.
				.BackStyle=0
				.Visible=.T.
			Endwith
		Endwith
	Endproc

	Procedure command4.Click
		Local m.delta
		Rand(-1)
		With Thisform
			Try
				.AddObject("commandGroup2","commandGroup")
			Catch
			Endtry
			With Thisform.commandgroup2
				.Top=This.Top
				.Left=This.Left+This.Width+10
				.ButtonCount=10
				For i=1 To .ButtonCount
					With .Buttons(i)
						.AutoSize=.T.
						.SpecialEffect=2
						.ForeColor=Rgb(255*Rand(),255*Rand(),255*Rand())
						.FontBold=.T.
						.MousePointer=15
					Endwith
				Endfor
				.AutoSize=.T.
				.BackStyle=0
				.Visible=.T.
			Endwith
		Endwith
	Endproc

	Procedure command5.Click
		Thisform.Activate()
	Endproc


Enddefine
*
*-- EndDefine: ybuttons


Working on VFP objects dynamically - partI

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


*4* updated on wednesday 07 december 2016
*this code shows how to animate some object on a form.
*it populates 8 empty images directly from the web with pictureVal property.(internet must be connected).
*it uses the bindevent() function to avoid many class creation.
*it integrates a web browser to raise flip effect on image (procedure ybuild).
*images objects are binded here in mouseEnter,MouseLeave and mouseDown.this provides some effects with mousemoving on the objects.
*as presented these 8 images can play a menu where can launch your applications....
*the destroyed form is also animated.
*mousemove on images or click on to see effects.

publi yform
yform=newObject("animated")
yform.show
read events
retu
*
DEFINE CLASS animated AS form
BorderStyle = 0
Height = 650
Width = 996
ShowWindow = 2
AutoCenter = .T.
Caption = "Mousemove or click any image"
MaxButton = .F.
BackColor = RGB(0,0,0)
showtips=.t.
delta = 30
Name = "Form1"

ADD OBJECT image1 AS image WITH ;
Stretch = 2, ;
Height = 100, ;
Left = 39, ;
Top = 152, ;
Width = 100, ;
Name = "Image1"

ADD OBJECT image2 AS image WITH ;
Stretch = 2, ;
Height = 100, ;
Left = 152, ;
Top = 77, ;
Width = 100, ;
Name = "Image2"

ADD OBJECT image3 AS image WITH ;
Stretch = 2, ;
Height = 100, ;
Left = 265, ;
Top = 53, ;
Width = 100, ;
Name = "Image3"

ADD OBJECT image4 AS image WITH ;
Stretch = 2, ;
Height = 100, ;
Left = 381, ;
Top = 14, ;
Width = 100, ;
Name = "Image4"


ADD OBJECT image6 AS image WITH ;
Height = 100, ;
Left = 601, ;
Top = 41, ;
Width = 100, ;
Name = "Image6"

ADD OBJECT image5 AS image WITH ;
Stretch = 2, ;
BackStyle = 1, ;
Height = 100, ;
Left = 489, ;
Top = 14, ;
Width = 100, ;
Name = "Image5"


ADD OBJECT image7 AS image WITH ;
Height = 100, ;
Left = 716, ;
Top = 78, ;
Width = 100, ;
Name = "Image7"

ADD OBJECT image8 AS image WITH ;
Stretch = 2, ;
Height = 100, ;
Left = 842, ;
Top = 142, ;
Width = 100, ;
Name = "Image8"

ADD OBJECT timer1 AS timer WITH ;
Top = 29, ;
Left = 896, ;
Height = 23, ;
Width = 23, ;
Enabled = .F., ;
Interval = 120, ;
Name = "Timer1"

ADD OBJECT label1 AS label WITH ;
FontBold = .F., ;
FontName = "BATAVIA", ;
FontSize = 24, ;
WordWrap = .T., ;
BackStyle = 0, ;
Caption = "Lorem ipsum dolor sit amet, consectetur adipiscing elit. Proin vel risus eget lorem feugiat.", ;
Height = 181, ;
Left = 324, ;
Top = 335, ;
Width = 301, ;
ForeColor = RGB(128,255,0), ;
Name = "Label1"

PROCEDURE my1
LPARAMETERS nButton, nShift, nXCoord, nYCoord
*--- aevent create an array laEvents
Aevents( myArray, 0)
*--- reference the calling object
loObject = myArray[1]
with loObject
.width=.width+thisform.delta
.height=.height+thisform.delta
.left=.left-thisform.delta/2
.top=.top-thisform.delta/2
.tooltiptext=loObject.name+"...to customize"
endwith
ENDPROC

PROCEDURE my2
LPARAMETERS nButton, nShift, nXCoord, nYCoord
*--- aevent create an array laEvents
Aevents( myArray, 0)
*--- reference the calling object
loObject = myArray[1]		
with loObject
.width=.width-thisform.delta
.height=.height-thisform.delta
.left=.left+thisform.delta/2
.top=.top+thisform.delta/2
endwith
ENDPROC

PROCEDURE my
LPARAMETERS nButton, nShift, nXCoord, nYCoord
*--- aevent create an array laEvents
Aevents( myArray, 0)
*--- reference the calling object
loObject = myArray[1]
if lower(loObject.name)=="image8"
thisform.release
else
thisform.ybuild()
inke(1)
messagebox("You clicked "+loObject.name+"......can fire any app from this point!",0+32+4096,"",1100)
endi
ENDPROC

procedure destroy
with thisform
.ybuild()
inkey(1)
do while .height>=50 and .width>=50
.height=.height-20
.width=.width-20
.left=.left+10
.top=.top+10
enddo
endwith
clea events
endproc

PROCEDURE Activate
with thisform.label1
do while .left<=thisform.width/2
.left=.left+10
sleep(50)
enddo
.left=(thisform.width-.width)/2
sleep(50)
endwith
ENDPROC

PROCEDURE Load
declare integer Sleep in kernel32 integer
ENDPROC

PROCEDURE Init
_screen.windowstate=1
with thisform
.setall("width",80,"image")
.setall("height",80,"image")
.setall("stretch",2,"image")
endwith

set memowidth to 8192  &&important to read one line once
local m.myvar
text to m.myvar noshow
https://cdn1.iconfinder.com/data/icons/logotypes/32/chrome-128.png
https://cdn1.iconfinder.com/data/icons/logotypes/32/internet-explorer-128.png
https://cdn3.iconfinder.com/data/icons/tango-icon-library/48/internet-web-browser-128.png
https://cdn3.iconfinder.com/data/icons/tango-icon-library/48/applications-internet-128.png
https://cdn2.iconfinder.com/data/icons/3d-bluefx-desktop-icons/128/Web.png
https://cdn3.iconfinder.com/data/icons/phuzion/PNG/System/Windows.png
https://cdn3.iconfinder.com/data/icons/tango-icon-library/48/applications-office-128.png
https://cdn2.iconfinder.com/data/icons/crystalproject/128x128/apps/exit.png
endtext

for i=1 to  memlines(m.myvar)
xURL=allt(mline(m.myvar,i))
with thisform
x=eval(".image"+trans(i))
**********
Local loRequest
m.loRequest = Createobject('MsXml2.XmlHttp')
m.loRequest.Open("GET",m.xUrl,.F.)
m.loRequest.Send()
x.pictureVal= m.loRequest.ResponseBody
loRequest=null
************
endwith
endfor

create cursor ycurs (y1 i, y2 i,y3 i,y4 i ,y5 i,y6 i,y7 i ,y8 i)  && to store initial top images as designed(after animation)
with thisform
insert into ycurs values (.image1.top,.image2.top,.image3.top,.image4.top,.image5.top,.image6.top,.image7.top,.image8.top)
.delta=50

for i=1 to 8
if lower(.controls(i).class)=="image"
.controls(i).mousePointer=15
.controls(i).stretch=2
bindevent(.controls(i),"mouseEnter",thisform,"my1")
bindevent(.controls(i),"mouseLeave",thisform,"my2")
bindevent(.controls(i),"mouseDown",thisform ,"my")
endi
endfor
.setall("top",-150,"image")
endwith

thisform.timer1.enabled=.t.
ENDPROC

PROCEDURE timer1.Timer
with thisform
.image1.top=.image1.top+10
.image2.top=.image1.top+10
.image3.top=.image1.top+10
.image4.top=.image1.top+10
.image5.top=.image1.top+10
.image6.top=.image1.top+10
.image7.top=.image1.top+10
.image8.top=.image1.top+10
endwith

if thisform.image1.top>250
this.enabled=.f.

for i=1 to 8
u=eval("thisform.image"+trans(i))
for j=0to 7
u.rotateflip=j
sleep(100)
j=j+1
endfor
u.rotateflip=0
endfor

sele ycurs
with thisform
.image1.top=y1
.image2.top=y2
.image3.top=y3
.image4.top=y4
.image5.top=y5
.image6.top=y6
.image7.top=y7
.image8.top=y8
.refresh
endwith

With Thisform.label1
Do While .Width>20 And .Height>20
.Width=.Width-2
.Left=.Left+1
sleep(10)
Enddo
Endwith
thisform.removeObject("label1")

*draw 1000 points as stars sky
rand(-1)
thisform.drawWidth=2
thisform.fillstyle=1
for i=1 to 1000
x=INT((thisform.width) * RAND( ) + 1)
y=INT((thisform.height) * RAND( ) + 1)
thisform.forecolor=rgb(255*rand(),255*rand(),255*rand())   &&rgb(255,255,255)
thisform.pset(x,y)
endfor
thisform.ybuild()
endi
ENDPROC

procedure ybuild

local m.myvar
text to m.myvar noshow
<style>
.flip {
-webkit-backface-visibility: visible;
backface-visibility: visible;
-webkit-animation-name: flip;
animation-name: flip;
-webkit-animation-duration: 1s;
animation-duration: 1s;
-webkit-animation-fill-mode: both;
animation-fill-mode: both;
}
@-webkit-keyframes flip {
0% {
-webkit-transform: perspective(400px) rotate3d(0, 1, 0, -360deg);
transform: perspective(400px) rotate3d(0, 1, 0, -360deg);
-webkit-animation-timing-function: ease-out;
animation-timing-function: ease-out;
}
40% {
-webkit-transform: perspective(400px) translate3d(0, 0, 150px) rotate3d(0, 1, 0, -190deg);
transform: perspective(400px) translate3d(0, 0, 150px) rotate3d(0, 1, 0, -190deg);
-webkit-animation-timing-function: ease-out;
animation-timing-function: ease-out;
}
50% {
-webkit-transform: perspective(400px) translate3d(0, 0, 150px) rotate3d(0, 1, 0, -170deg);
transform: perspective(400px) translate3d(0, 0, 150px) rotate3d(0, 1, 0, -170deg);
-webkit-animation-timing-function: ease-in;
animation-timing-function: ease-in;
}
80% {
-webkit-transform: perspective(400px) scale3d(.95, .95, .95);
transform: perspective(400px) scale3d(.95, .95, .95);
-webkit-animation-timing-function: ease-in;
animation-timing-function: ease-in;
}
100% {
-webkit-transform: perspective(400px);
transform: perspective(400px);
-webkit-animation-timing-function: ease-in;
animation-timing-function: ease-in;
}
}
@keyframes flip {
0% {
-webkit-transform: perspective(400px) rotate3d(0, 1, 0, -360deg);
transform: perspective(400px) rotate3d(0, 1, 0, -360deg);
-webkit-animation-timing-function: ease-out;
animation-timing-function: ease-out;
}
40% {
-webkit-transform: perspective(400px) translate3d(0, 0, 150px) rotate3d(0, 1, 0, -190deg);
transform: perspective(400px) translate3d(0, 0, 150px) rotate3d(0, 1, 0, -190deg);
-webkit-animation-timing-function: ease-out;
animation-timing-function: ease-out;
}
50% {
-webkit-transform: perspective(400px) translate3d(0, 0, 150px) rotate3d(0, 1, 0, -170deg);
transform: perspective(400px) translate3d(0, 0, 150px) rotate3d(0, 1, 0, -170deg);
-webkit-animation-timing-function: ease-in;
animation-timing-function: ease-in;
}
80% {
-webkit-transform: perspective(400px) scale3d(.95, .95, .95);
transform: perspective(400px) scale3d(.95, .95, .95);
-webkit-animation-timing-function: ease-in;
animation-timing-function: ease-in;
}
100% {
-webkit-transform: perspective(400px);
transform: perspective(400px);
-webkit-animation-timing-function: ease-in;
animation-timing-function: ease-in;
}
}
</style>

<body topmargin=50 bgcolor=black oncontextmenu="return false;" scroll="no">
<center><div class="flip" ><img src="http://img.over-blog-kiwi.com/1/43/54/07/20150209/ob_78a803_fennec.png" width="200"  height="220"  style="border: 10px solid #fff;-webkit-border-radius: 15px;border-radius: 50%;overflow: hidden;"></div></center>
endtext

local m.lcdest
m.lcdest=addbs(sys(2023))+"ytemp.html"
set safe off
strtofile(m.myvar,m.lcdest)

try
thisform.addobject("olecontrol1","olecontrol","shell.explorer.2")
catch
endtry

with thisform.olecontrol1
.width=400
.height=400
.left=(thisform.width-.width)/2
.top=(thisform.height-.height)/2 +100
.visible=.t.

.navigate(m.lcdest)
endwith
endproc

PROCEDURE label1.Init
this.left=-200
ENDPROC

ENDDEFINE
*
*-- EndDefine: animated


can make form alwaysontop=.t.  to avoid be covered by another windows....can arrange icons png as your taste.
can make form alwaysontop=.t.  to avoid be covered by another windows....can arrange icons png as your taste.

can make form alwaysontop=.t. to avoid be covered by another windows....can arrange icons png as your taste.

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


*5* updated on thursday 08 decemeber 2016
*this code make a zoom simulation on images controls on the form.
*images are populated with the technic of pictureVal directly from the web(all in memory no trace on disc(internet connected).
*
Publi yform
yform=Newobject("yzoom")
yform.Show
Read Events
Retu
*
Define Class yzoom As Form
	BorderStyle = 0
	Top = 13
	Left = 35
	Height = 554
	Width = 923
	ShowWindow = 2
	Caption = "Zoom effect on image: MouseMove on images to zoom or click."
	BackColor = Rgb(0,0,0)
	left0 = .F.
	top0 = .F.
	width0 = .F.
	height0 = .F.
	Name = "Form1"

	Add Object image1 As Image With ;
		Stretch = 2, ;
		Height = 156, ;
		Left = 33, ;
		Top = 65, ;
		Width = 180, ;
		Name = "Image1"

	Add Object image2 As Image With ;
		Stretch = 2, ;
		Height = 156, ;
		Left = 234, ;
		Top = 37, ;
		Width = 180, ;
		Name = "Image2"

	Add Object image3 As Image With ;
		Stretch = 2, ;
		Height = 156, ;
		Left = 438, ;
		Top = 62, ;
		Width = 180, ;
		Name = "Image3"

	Add Object image4 As Image With ;
		Stretch = 2, ;
		Height = 156, ;
		Left = 33, ;
		Top = 276, ;
		Width = 180, ;
		Name = "Image4"

	Add Object image5 As Image With ;
		Stretch = 2, ;
		Height = 156, ;
		Left = 236, ;
		Top = 307, ;
		Width = 180, ;
		Name = "Image5"

	Add Object image6 As Image With ;
		Stretch = 2, ;
		Height = 156, ;
		Left = 440, ;
		Top = 276, ;
		Width = 180, ;
		Name = "Image6"

	Add Object image7 As Image With ;
		Stretch = 2, ;
		Height = 156, ;
		Left = 680, ;
		Top = 132, ;
		Width = 180, ;
		Name = "Image7"

	Add Object label1 As Label With ;
		Caption = "Label1", ;
		Height = 36, ;
		Left = 24, ;
		Top = 504, ;
		Visible = .F., ;
		Width = 240, ;
		Name = "Label1"

	Procedure my1
		Lparameters nButton, nShift, nXCoord, nYCoord
		*--- aevent create an array laEvents
		Aevents( myArray, 0)
		*--- reference the calling object
		loObject = myArray[1]
		With loObject
			Thisform.left0=.Left
			Thisform.top0=.Top
			Thisform.width0=.Width
			Thisform.height0=.Height
		Endwith

		With loObject
			.Stretch=1
			.BorderStyle=1
			For i=1 To 60 Step 2
				Try
					.Left=.Left-1
					.Top=.Top-1
					.Width=.Width+2
					.Height=.Height+2
					sleep(10)
				Catch
				Endtry
			Endfor
		Endwith
	Endproc

	Procedure my2
		Parameters nButton, nShift, nXCoord, nYCoord
		*--- aevent create an array laEvents
		Aevents( myArray, 0)
		*--- reference the calling object
		loObject = myArray[1]
		With loObject
			.Stretch=1

			With loObject
				.Stretch=1
				.BorderStyle=0
				For i=1 To 60 Step 2
					Try
						.Left=.Left+1
						.Top=.Top+1
						.Width=.Width-2
						.Height=.Height-2
						sleep(10)
					Catch
					Endtry
				Endfor
			Endwith
		Endwith

		With loObject
			.Left=Thisform.left0
			.Top=Thisform.top0
			.Width=Thisform.width0
			.Height=Thisform.height0
		Endwith
	Endproc

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

		If loObject.Name="image7"
			Thisform.Release

		Else

			With Thisform.label1
				.Caption=loObject.Name+" clicked.Can fire any code from here!"
				.Visible=.T.
				Local t0
				t0=Seconds()
				Do While Seconds()-t0<=1.2
				Enddo
				.Visible=.F.
			Endwith
		Endi
	Endproc

	Procedure Load
		Declare Integer Sleep In kernel32 Integer
	Endproc

	Procedure Destroy
		Clea Events
	Endproc

	Procedure Init
		Set Memowidth To 8192  &&important to read one line once
		Local m.myvar
		TEXT to m.myvar noshow
		https://cdn1.iconfinder.com/data/icons/logotypes/32/chrome-128.png
		https://cdn1.iconfinder.com/data/icons/logotypes/32/internet-explorer-128.png
		https://cdn3.iconfinder.com/data/icons/tango-icon-library/48/internet-web-browser-128.png
		https://cdn2.iconfinder.com/data/icons/3d-bluefx-desktop-icons/128/Web.png
		https://cdn3.iconfinder.com/data/icons/phuzion/PNG/System/Windows.png
		https://cdn3.iconfinder.com/data/icons/tango-icon-library/48/applications-office-128.png
		https://cdn2.iconfinder.com/data/icons/crystalproject/128x128/apps/exit.png
		ENDTEXT

		For i=1 To  Memlines(m.myvar)
			xURL=Allt(Mline(m.myvar,i))
			With Thisform
				x=Eval(".image"+Trans(i))
				**********
				Local loRequest
				m.loRequest = Createobject('MsXml2.XmlHttp')
				m.loRequest.Open("GET",m.xURL,.F.)
				m.loRequest.Send()
				x.PictureVal= m.loRequest.ResponseBody
				loRequest=Null
				************
			Endwith
		Endfor
		***************

		With Thisform
			.SetAll("mousepointer",15,"image")
			.SetAll("stretch",1,"image")
			For i=1 To .ControlCount
				If Lower(.Controls(i).Class)=="image"
					Bindevent(.Controls(i),"mouseEnter",Thisform,"my1")
					Bindevent(.Controls(i),"mouseLeave",Thisform,"my2")
					Bindevent(.Controls(i),"mouseDown",Thisform,"my")
				Endi
			Endfor
		Endwith
	Endproc

	Procedure image7.Click
		DoDefault()
		Thisform.Release
	Endproc

	Procedure label1.Init
		With This
			.Anchor=768
			.AutoSize=.T.
			.Caption=""
			.FontSize=16
			.FontBold=.T.
			.BackStyle=0
			.ForeColor=255
			.Visible=.F.
		Endwith
	Endproc


Enddefine
*
*-- EndDefine: yzoom


Working on VFP objects dynamically - partI

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


*6* updated on thursday 8 december 2016
*this draws some curves as sin,cos...advantagely with shapes objects instead of points by the native function PSET
*the shape object have PEM and can be manipulated as object dynamically.
*this method can draw any figure given with its points (path or equation).


Publi yform
yform=Newobject("ydrawing")
yform.Show
Read Events
Retu
*
Define Class ydrawing As Form
	BorderStyle = 0
	Height = 557
	Width = 902
	ShowWindow=2
	AutoCenter = .T.
	Caption = "Drawing curves with shapes."
	WindowState = 0
	BackColor = Rgb(0,0,0)
	Name = "Form1"

	Procedure Load
		Declare Integer Sleep In kernel32 Integer
		Create Cursor ycurs (x i,Y i,z i)
		For i=1 To 900
			Insert Into ycurs Values (i,180*Sin(Pi()*i/180),180*Cos(Pi()*i/180))
		Endfor
		*brow
	Endproc

	Procedure Activate
		*draw 1000 random points as stars sky
		Rand(-1)
		Thisform.DrawWidth=2
		Thisform.FillStyle=7
		Local xx, yy
		For i=1 To 1000
			xx=Int((Thisform.Width) * Rand( ) + 1)
			yy=Int((Thisform.Height) * Rand( ) + 1)
			Thisform.ForeColor=Rgb(255*Rand(),255*Rand(),255*Rand())
			Thisform.PSet(xx,yy)
		Endfor

		Sele ycurs
		Scan
			With Thisform
				x="shp"+Sys(2015)
				Y="shp"+Sys(2015)
				.AddObject(m.x,"shape")

				With Eval("."+m.x)
					.BackColor=Rgb(255*Rand(),255*Rand(),255*Rand())
					.Curvature=25
					.Width=20
					.Height=20
					.Left=x
					.Top=Y+Thisform.Height/2
					.Visible=.T.
				Endwith

				.AddObject(m.y,"shape")
				With Eval("."+m.y)
					.BackColor=Rgb(255*Rand(),255*Rand(),255*Rand())
					.Curvature=99
					.Width=20
					.Height=20
					.Left=x
					.Top=z+Thisform.Height/2
					.Visible=.T.
				Endwith
				Sleep(2)
			Endwith
		Endscan
	Endproc

	Procedure Destroy
		Clea Events
	Endproc


Enddefine
*
*-- EndDefine: ydrawing


Working on VFP objects dynamically - partI

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


*7*
*Friday 09 december  2016
*An object motion on any path given by its coordonees x,y
*A timer makes the motion each 100 ms - Press ESC at any time to stop motion.
*the path can be captured point by point (see shape & maps article)
*object can be any vfp one (image,icon,button...its a shape & image here)-for image choose transparent PNGs.

Publi oform
oform=Newobject("ymotion")
oform.Show
Read Events
Retu

Define Class ymotion  As Form
	BorderStyle = 0
	Top = 16
	Left = 33
	Height = 600
	Width = 900
	ShowWindow = 2
	AutoCenter=.T.
	Caption = "Motion on any path  - Issue ESC to stop the motion."
	BackColor = Rgb(0,0,0)
  ii=0
	Name = "Form1"

	Add Object shape1 As Shape With ;
		Top = 72, ;
		Left = 72, ;
		Height = 36, ;
		Width = 37, ;
		BorderStyle = 1, ;
		BorderWidth = 2, ;
		Curvature = 99, ;
		BackColor = Rgb(0,255,0), ;
		BorderColor = Rgb(255,0,0), ;
		Name = "Shape1"

  Add Object image1 As Image With ;
		Top = -50, ;
    Left = 0, ;
picture=home(1)+"graphics\bitmaps\assorted\beany.bmp"	, ;
    backstyle=0  ,  ; 	
    Name = "Image1"

	Add Object timer1 As Timer With ;
		Top = 24, ;
		Left = 720, ;
		Height = 23, ;
		Width = 23, ;
		Interval = 100, ;
		Name = "Timer1"

	Procedure Init
		With Thisform
			.DrawWidth=5
			.FillStyle=0
		Endwith
	Endproc

	Procedure Load
		Create Cursor ycurs (x i, Y i)
		Local m.myvar
		TEXT to m.myvar noshow
		         89        207
		         96        162
		         98        133
		        117        107
		        134         84
		        149         64
		        184         43
		        212         37
		        234         42
		        253         64
		        247        102
		        232        142
		        223        180
		        208        216
		        196        233
		        165        260
		        165        264
		        130        305
		         99        337
		         74        388
		         64        431
		         59        472
		         74        517
		         83        550
		         86        554
		        100        583
		        121        598
		        189        612
		        225        608
		        225        608
		        252        602
		        277        586
		        277        586
		        288        562
		        328        526
		        328        526
		        328        526
		        342        492
		        362        440
		        370        421
		        381        373
		        395        326
		        408        281
		        426        258
		        426        258
		        438        226
		        483        184
		        513        158
		        545        137
		        569        124
		        584        120
		        602        110
		        624        105
		        646        102
		        673        105
		        689        110
		        710        118
		        740        136
		        760        154
		        779        184
		        788        205
		        801        246
		        811        273
		        814        283
		        822        324
		        823        370
		        808        411
		        800        429
		        790        445
		        770        463
		        748        474
		        734        479
		        706        481
		        667        483
		        641        478
		        618        474
		        599        467
		        572        454
		        528        433
		        510        424
		        504        421
		        471        396
		        459        384
		        424        341
		        422        337
		        408        316
		        388        294
		        342        256
		        332        246
		        278        198
		        278        198
		        256        189
		        228        178
		        217        172
		        187        158
		        175        154
		        135        154
		         94        170
		         49        202
		         49        203
		         18        245
		         15        260
		          6        306
		         10        332
		         30        414
		         35        419
		         75        443
		        108        457
		        194        481
		        204        482
		        322        463
		        356        453
		        393        431
		        427        405
		        449        354
		        459        345
		        499        301
		        526        269
		        553        234
		        576        217
		        606        197
		        649        180
		        751        169
		        834        220
		        865        245
		        910        324
		        922        357
		        942        425
		        947        456
		        956        488
		        963        531
		        966        557
		        967        563
		       1012        617
		ENDTEXT
		For i=1 To Memlines(m.myvar)
			x1=Int(Val(Getwordnum(Mline(m.myvar,i),1)))
			y1=Int(Val(Getwordnum(Mline(m.myvar,i),2)))

			Insert Into ycurs Values(x1,y1)
		Endfor
		*brow
    locate
	Endproc

	Procedure KeyPress
		Lparameters nKeyCode, nShiftAltCtrl
		If nKeyCode=27
			Thisform.timer1.Enabled=.F.
		Endi
	Endproc

	Procedure Destroy
		Clea Events
	Endproc

	Procedure timer1.Timer
sele ycurs
if !eof()
skip
else
locate
thisform.ii=iif(thisform.ii=0,1,0)
if thisform.ii=1
thisform.shape1.top=-50
else
thisform.image1.top=-50
endi
thisform.cls
endi

if thisform.ii=0
m.oo="shape1"
else
m.oo="image1"
endi

with eval("thisform."+m.oo)
.left=x-.width/2
.top=y-.height/2
thisform.forecolor=rgb(255*rand(),255*rand(),255*rand())
thisform.fillcolor=rgb(255*rand(),255*rand(),255*rand())
thisform.pset(x-.width-5,y-.height-5)
endwith
	Endproc

Enddefine
*
*-- EndDefine: ymotion


of course vfp form can be also moved/animated with method (for alerts apps for ex)

of course vfp form can be also moved/animated with method (for alerts apps for ex)

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


*8* created on 31 of december 2016
*create a menu with some labels controls and use bindevent() function to make some animation(mouseEnter/mouseLeave)

publi yform
yform=newObject("ymenu")
yform.show
read events
retu
*
DEFINE CLASS ymenu AS form
	BorderStyle = 3
	Top = 0
	Left = 0
	Height = 489
	Width = 793
	ShowWindow = 2
	Caption = "Menu sample with label controls & bindevent"
	BackColor = RGB(0,0,0)
	ylab = .F.
	Name = "Form1"

	ADD OBJECT container1 AS ycont WITH ;
		Anchor = 768, ;
		Top = 4, ;
		Left = 12, ;
		Width = 282, ;
		Height = 456, ;
		BackStyle = 0, ;
		BorderWidth = 0, ;
		Name = "Container1"


	PROCEDURE my
		LPARAMETERS nButton, nShift, nXCoord, nYCoord
		*--- aevent create an array laEvents
		Aevents( myArray, 0)
		*--- reference the calling object
		loObject = myArray[1]
		loObject.forecolor=255

		with loObject.parent
		local ylab
		ylab="ylab"+sys(2015)
		thisform.ylab=m.ylab
		.addoBject(m.ylab,"label")
		with eval("."+m.ylab)
		.left  =loObject.left+6
		.top   =loObject.top+6
		.width =loObject.width
		.height=loObject.height
		.backcolor=rgb(255,168,168)
		.zorder(1)
		.visible=.t.
		endwith

		.yinfo.caption="code something from "+loObject.name +" in click event."
		endwith
	ENDPROC


	PROCEDURE my1
		LPARAMETERS nButton, nShift, nXCoord, nYCoord
		*--- aevent create an array laEvents
		Aevents( myArray, 0)
		*--- reference the calling object
		loObject = myArray[1]
		loObject.forecolor=rgb(0,255,255)
		try
		loObject.parent.removeObject(thisform.ylab)
		catch
		endtry
	ENDPROC

	PROCEDURE Destroy
		clea events
	ENDPROC

ENDDEFINE
*
*-- EndDefine: ymenu

DEFINE CLASS ycont AS container
	Anchor = 768
	Top = 4
	Left = 12
	Width = 282
	Height = 456
	BackStyle = 0
	BorderWidth = 0
	Name = "Container1"

	ADD OBJECT label1 AS label WITH ;
		FontBold = .T., ;
		FontSize = 14, ;
		Alignment = 2, ;
		BorderStyle = 0, ;
		Caption = "Label1", ;
		Height = 37, ;
		Left = 6, ;
		Top = 9, ;
		Width = 240, ;
		ForeColor = RGB(255,255,0), ;
		BackColor = RGB(128,128,255), ;
		Name = "Label1"

	ADD OBJECT label2 AS label WITH ;
		FontBold = .T., ;
		FontSize = 14, ;
		Alignment = 2, ;
		BorderStyle = 0, ;
		Caption = "Label1", ;
		Height = 37, ;
		Left = 6, ;
		Top = 56, ;
		Width = 240, ;
		ForeColor = RGB(255,255,0), ;
		BackColor = RGB(128,128,255), ;
		Name = "Label2"

	ADD OBJECT label3 AS label WITH ;
		FontBold = .T., ;
		FontSize = 14, ;
		Alignment = 2, ;
		BorderStyle = 0, ;
		Caption = "Label1", ;
		Height = 37, ;
		Left = 6, ;
		Top = 102, ;
		Width = 240, ;
		ForeColor = RGB(255,255,0), ;
		BackColor = RGB(128,128,255), ;
		Name = "Label3"

	ADD OBJECT label4 AS label WITH ;
		FontBold = .T., ;
		FontSize = 14, ;
		Alignment = 2, ;
		BorderStyle = 0, ;
		Caption = "Label1", ;
		Height = 37, ;
		Left = 6, ;
		Top = 150, ;
		Width = 240, ;
		ForeColor = RGB(255,255,0), ;
		BackColor = RGB(128,128,255), ;
		Name = "Label4"

	ADD OBJECT label5 AS label WITH ;
		FontBold = .T., ;
		FontSize = 14, ;
		Alignment = 2, ;
		BorderStyle = 0, ;
		Caption = "Label1", ;
		Height = 37, ;
		Left = 6, ;
		Top = 199, ;
		Width = 240, ;
		ForeColor = RGB(255,255,0), ;
		BackColor = RGB(128,128,255), ;
		Name = "Label5"

	ADD OBJECT label6 AS label WITH ;
		FontBold = .T., ;
		FontSize = 14, ;
		Alignment = 2, ;
		BorderStyle = 0, ;
		Caption = "Label1", ;
		Height = 37, ;
		Left = 6, ;
		Top = 247, ;
		Width = 240, ;
		ForeColor = RGB(255,255,0), ;
		BackColor = RGB(128,128,255), ;
		Name = "Label6"

	ADD OBJECT label7 AS label WITH ;
		FontBold = .T., ;
		FontSize = 14, ;
		Alignment = 2, ;
		BorderStyle = 0, ;
		Caption = "Label1", ;
		Height = 37, ;
		Left = 6, ;
		Top = 293, ;
		Width = 240, ;
		ForeColor = RGB(255,255,0), ;
		BackColor = RGB(128,128,255), ;
		Name = "Label7"

	ADD OBJECT label8 AS label WITH ;
		FontBold = .T., ;
		FontSize = 14, ;
		Alignment = 2, ;
		BorderStyle = 0, ;
		Caption = "Label1", ;
		Height = 37, ;
		Left = 6, ;
		Top = 341, ;
		Width = 240, ;
		ForeColor = RGB(255,255,0), ;
		BackColor = RGB(128,128,255), ;
		Name = "Label8"

	ADD OBJECT yinfo AS label WITH ;
		AutoSize = .F., ;
		FontBold = .T., ;
		FontSize = 14, ;
		WordWrap = .T., ;
		Alignment = 2, ;
		BackStyle = 1, ;
		Caption = "Label7          ", ;
		Height = 57, ;
		Left = 6, ;
		Top = 387, ;
		Width = 240, ;
		ForeColor = RGB(255,255,0), ;
		BackColor = RGB(0,0,0), ;
		Name = "yinfo"


	PROCEDURE Init
		local m.myvar
		text to m.myvar noshow
		1. my 2017 projects
		2. my librairies
		3. forms and prgs
		4. executables
		5. images
		6. icons
		7. Help
		8. exit
		endtext
		local m.x
		with this
		for i=1 to memlines(m.myvar)
		m.x=".label"+trans(i)+".caption"
		&x=allt(mline(m.myvar,i))
		bindevent(eval(".label"+trans(i)),"mouseEnter",thisform,"my")
		bindevent(eval(".label"+trans(i)),"mouseLeave",thisform,"my1")
		endfor
		.setall("alignment",2,"label")
		.setall("mousepointer",15,"label")
		endwith
	ENDPROC

	PROCEDURE label8.Click
		thisform.release
	ENDPROC

ENDDEFINE
*
*-- EndDefine: ycont



Working on VFP objects dynamically - partI

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


*9* what  textbox control have the focus among 20 ones ? a color  particularize the control having the gotfocus
*use bindevent() function
*a random texbox is choosed programmatly to set the focus & firing a message
*the gotfocus event Occurs when an object receives the focus, either by user action or through code.

Publi yform
yform=Newobject("asup")
yform.Show
Read Events
Retu

Define Class asup As Form
	Top = 0
	Left = 0
	Height = 192
	Width = 916
	Caption = "Click on any textbox  or Move with TAB"
	BackColor = Rgb(210,208,212)
	Name = "Form1"

	Add Object command1 As CommandButton With ;
		AutoSize = .T., ;
		Top = 120, ;
		Left = 24, ;
		Height = 29, ;
		Width = 112, ;
		FontBold = .T., ;
		FontSize = 10, ;
		Caption = "Programmatly", ;
		MousePointer = 15, ;
		BackColor = Rgb(128,255,0), ;
		Name = "Command1"

	Procedure my
		*--- aevent create an array laEvents
		Aevents( myArray, 0)
		*--- reference the calling object
		loObject = myArray[1]
		Thisform.SetAll("Backcolor",Rgb(254,254,254),"textbox")
		loObject.BackColor=Rgb(0,0,255)
		Messagebox(loObject.Name+ " have the focus!",0+32+4096,'',1000)
    **could be also directly: thisform.activecontrol.name
	Endproc

	Procedure Destroy
		Clea Events
	Endproc

	Procedure Init
		With Thisform
			Local m.o
			For i=1 To 20
				m.o="text"+Trans(i)
				.AddObject(m.o,"textbox")
				With Eval("."+m.o)
					If i=1
						.Left=5
						.Top=20
					Else
						.Left=Eval("thisform.text"+Trans(i-1)+".left")+Eval("thisform.text"+Trans(i-1)+".width")+5
						.Top=20
					Endi
					.Width=40
					.Value=m.o
					.Visible=.T.
				Endwith
				*Occurs when an object receives the focus, either by user action or through code.
				Bindevent(Eval("thisform."+m.o),"gotfocus",Thisform,"my")
			Endfor
		Endwith
	Endproc

	Procedure command1.Click
		*thisform.text9.setfocus
		Rand(-1)
		Local m.x  && a randomnumber between 1,20
		m.x="thisform.text"+ Trans(Int(20*Rand()+ 1)) +".setfocus()"
		&x
	Endproc

Enddefine
*
*-- EndDefine: asup


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

                        

*10* created on 02 of january 2017
*this code creates a menu with icons grabbed directly from the web(no disc).
*4 containers each one relative to a menu option......can customize...
*each submenu is hidden over the form top and animated when called.
*images are populated directly from the web (internet must be connected).
*this can simulates a modern menu for desktop application.

publi oform
oform=newObject("yicon_menu")
oform.show
read events
retu
*
DEFINE CLASS yicon_menu AS form
BorderStyle = 3
Height = 509
Width = 975
ShowWindow = 2
AutoCenter = .T.
Caption = "Web icons menu on form --Choose any menu and click on sub image menu."
BackColor = RGB(0,0,0)
Name = "Form1"

ADD OBJECT ymenu AS ymenu0 WITH ;
	Top = 120, ;
	Left = 36, ;
	Width = 768, ;
	Height = 72, ;
	BackStyle = 1, ;
	BorderWidth = 0, ;
	BackColor = RGB(0,255,0), ;
	Name = "ymenu"

ADD OBJECT container1 AS ycont WITH ;
	Top = 324, ;
	Left = 60, ;
	Width = 288, ;
	Height = 60, ;
	BackStyle = 1, ;
	BorderWidth = 0, ;
	BackColor = RGB(0,0,0), ;
	Name = "Container1"

ADD OBJECT container2 AS ycont WITH ;
	Top = 156, ;
	Left = 468, ;
	Width = 300, ;
	Height = 60, ;
	BackStyle = 1, ;
	BorderWidth = 0, ;
	BackColor = RGB(0,0,0), ;
	Name = "Container2"

ADD OBJECT container3 AS ycont WITH ;
	Top = 348, ;
	Left = 396, ;
	Width = 300, ;
	Height = 60, ;
	BackStyle = 1, ;
	BorderWidth = 0, ;
	BackColor = RGB(0,0,0), ;
	Name = "Container3"

ADD OBJECT container4 AS ycont WITH ;
	Top = 348, ;
	Left = 396, ;
	Width = 300, ;
	Height = 60, ;
	BackStyle = 1, ;
	BorderWidth = 0, ;
	BackColor = RGB(0,0,0), ;
	Name = "Container4"
	
PROCEDURE ycollapse
	with thisform.container1
	.top=-.height-10
	.left=(thisform.width-.width)/2
	endwith

	with thisform.container2
	.top=-.height-10
	.left=(thisform.width-.width)/2
	endwith

	with thisform.container3
	.top=-.height-10
	.left=(thisform.width-.width)/2
	endwith

	with thisform.container4
	.top=-.height-10
	.left=(thisform.width-.width)/2
	endwith
ENDPROC

PROCEDURE yexpand
	lparameters xx
	thisform.ycollapse()

	with xx
	do while .top<=thisform.ymenu.top+thisform.ymenu.height+5
	.top=.top+20
	inke(0.1)
	enddo
	.top=thisform.ymenu.top+thisform.ymenu.height+5
	endwith
ENDPROC

PROCEDURE my1
	LPARAMETERS nButton, nShift, nXCoord, nYCoord
	*--- aevent create an array laEvents
	Aevents( myArray, 0)
	*--- reference the calling object
	loObject = myArray[1]
	with loObject
	.left=.left-2
	.top=.top-2
	endwith

	do case
	case  lower(loObject.name)=="image1"
	loObject.parent.label1.caption="this is my main menu 1"
	case lower(loObject.name)=="image2"
	loObject.parent.label1.caption="this is my main menu 2"
	case lower(loObject.name)=="image3"
	loObject.parent.label1.caption="this is my main menu 3"
	case lower(loObject.name)=="image4"
	loObject.parent.label1.caption="this is my main menu 4"
	endcase
ENDPROC

PROCEDURE my2
	LPARAMETERS nButton, nShift, nXCoord, nYCoord
	Aevents( myArray, 0)
	*--- reference the calling object
	loObject = myArray[1]
	with loObject
	.left=.left+2
	.top=.top+2
	endwith
	loObject.parent.label1.caption=""
ENDPROC

PROCEDURE my
	LPARAMETERS nButton, nShift, nXCoord, nYCoord
	*--- aevent create an array laEvents
	Aevents( myArray, 0)
	*--- reference the calling object
	loObject = myArray[1]
	messagebox(loObject.parent.name+"."+loObject.name +" clicked   can do some things from here!",0+32+4096,"",1300)
ENDPROC

PROCEDURE ysetimg
	*request for web to populate images (internet must be connected)
*ymenu
with thisform.ymenu
thisform.yload(.image1,"https://cdn3.iconfinder.com/data/icons/aurora/PNG/128x128/icontexto-aurora-folders-windows.png")
thisform.yload(.image2,"https://cdn0.iconfinder.com/data/icons/yooicons_set01_socialbookmarks/128/social_windows_button.png")
thisform.yload(.image3,"https://cdn1.iconfinder.com/data/icons/ilive-by-wwalczyszyn/128/Windows_Live_Gallery.png")
thisform.yload(.image4,"https://cdn2.iconfinder.com/data/icons/hexagon-social-medias/462/Social_Hexagon_Icons-29-128.png")
endwith


*container1
with thisform.container1
thisform.yload(.image1,"https://cdn0.iconfinder.com/data/icons/brands-colored-1/60/windows-desktop-os-software-128.png")
thisform.yload(.image2,"https://cdn0.iconfinder.com/data/icons/social-network-7/50/14-128.png")
thisform.yload(.image3,"https://cdn1.iconfinder.com/data/icons/my--icons-by-itzikgur/128/Programs_-_Windows.png")
thisform.yload(.image4,"https://cdn2.iconfinder.com/data/icons/icons-mega-pack-1-and-2/128/Windows_Media_Center.png")
thisform.yload(.image5,"https://cdn2.iconfinder.com/data/icons/folders-22/128/Folder_Win.png")
endwith

*container2
with thisform.container2
thisform.yload(.image1,"https://cdn0.iconfinder.com/data/icons/iwindows-by-wwalczyszyn-d3dwi6l/128/Windows_DVD_Maker.png")
thisform.yload(.image2,"https://cdn2.iconfinder.com/data/icons/icons-mega-pack-1-and-2/128/Windows_Media_Player_9.png")
thisform.yload(.image3,"https://cdn4.iconfinder.com/data/icons/Ethereal_Icons_2/PNGs/Drives/Windows.png")
thisform.yload(.image4,"https://cdn4.iconfinder.com/data/icons/refresh_cl/128/Windows/Windows_Table.png")
thisform.yload(.image5,"https://cdn2.iconfinder.com/data/icons/apps-3/128/Security_Center.png")
endwith

*container3
with thisform.container3
thisform.yload(.image1,"https://cdn2.iconfinder.com/data/icons/sleekxp/Windows-Turn-Off.png")
thisform.yload(.image2,"https://cdn2.iconfinder.com/data/icons/circular-icon-set/128/Windows.png")
thisform.yload(.image3,"https://cdn0.iconfinder.com/data/icons/creative-nerds-wooden-icons/128/windows.png")
thisform.yload(.image4,"https://cdn4.iconfinder.com/data/icons/refresh_cl/128/Windows/Windows_Luna.png")
thisform.yload(.image5,"https://cdn1.iconfinder.com/data/icons/KDE_Crystal_Diamond_2.5_Classical_Mod/128x128/apps/windows_users.png")
endwith

*container4
with thisform.container4
thisform.yload(.image1,"https://cdn2.iconfinder.com/data/icons/scrap/Windows%20Explorer.png")
thisform.yload(.image2,"https://cdn2.iconfinder.com/data/icons/sleekxp/Windows-Media-Player.png")
thisform.yload(.image3,"https://cdn2.iconfinder.com/data/icons/folders-22/128/Folder_Mac_Windows.png")
thisform.yload(.image4,"https://cdn4.iconfinder.com/data/icons/iconset-addictive-flavour/png/screen_windows.png")
thisform.yload(.image5,"https://cdn2.iconfinder.com/data/icons/disk-drives/128/Internal_Drive_Windows.png")
endwith

with thisform
for j=1 to .controlcount
	if lower(.controls(j).baseclass)=="container" and !lower(.controls(j).name)=="ymenu"
	with .controls(j)
	for i=1 to .controlcount
	if lower(.controls(i).class)=="image"
	bindevent(.controls(i),"mousedown",thisform,"my")
	endi
	endfor
	endwith
	endi
endfor

endwith
ENDPROC

PROCEDURE yload
	lparameters  obj,lcurl
If Empty(lcURl)
		Return .F.
	Endi
Local loRequest
	Try
		m.loRequest = Createobject('MsXml2.XmlHttp')
		m.loRequest.Open("GET",lcURl,.F.)
		m.loRequest.Send()
		obj.pictureval=m.loRequest.ResponseBody
		m.loRequest=Null
	Catch
	messagebox("An error was occured!",16+4096,"",1200)
	Endtry
ENDPROC

PROCEDURE Destroy
	clea events
ENDPROC

PROCEDURE Init
	thisform.ysetImg()		
ENDPROC
ENDDEFINE
*
*-- EndDefine: yicon_menu

DEFINE CLASS ymenu0 AS container
Top = 0
Left = 132
Width = 768
Height = 72
BackStyle = 1
Name = "ymenu"

ADD OBJECT image1 AS image WITH ;
	Stretch = 1, ;
	Height = 64, ;
	Left = 125, ;
	MousePointer = 15, ;
	Top = -1, ;
	Width = 64, ;
	Name = "Image1"

ADD OBJECT image2 AS image WITH ;
	Stretch = 2, ;
	Height = 64, ;
	Left = 209, ;
	MousePointer = 15, ;
	Top = -1, ;
	Width = 64, ;
	Name = "Image2"

ADD OBJECT command1 AS commandbutton WITH ;
	AutoSize = .T., ;
	Top = 11, ;
	Left = 9, ;
	Height = 29, ;
	Width = 97, ;
	FontBold = .T., ;
	FontSize = 10, ;
	Caption = "Collapse all", ;
	MousePointer = 15, ;
	BackColor = RGB(128,255,0), ;
	Name = "Command1"


ADD OBJECT image3 AS image WITH ;
	Stretch = 2, ;
	Height = 64, ;
	Left = 303, ;
	MousePointer = 15, ;
	Top = -1, ;
	Width = 64, ;
	Name = "Image3"

ADD OBJECT label1 AS label WITH ;
	AutoSize = .T., ;
	FontSize = 14, ;
	BackStyle = 0, ;
	Caption = "", ;
	Height = 25, ;
	Left = 465, ;
	Top = 25, ;
	Width = 2, ;
	ForeColor = RGB(255,0,0), ;
	Name = "Label1"

ADD OBJECT image4 AS image WITH ;
	Stretch = 2, ;
	BackStyle = 0, ;
	Height = 64, ;
	Left = 381, ;
	MousePointer = 15, ;
	Top = -1, ;
	Width = 64, ;
	Name = "Image4"

ADD OBJECT command2 AS commandbutton WITH ;
	AutoSize = .T., ;
	Top = 6, ;
	Left = 709, ;
	Height = 32, ;
	Width = 53, ;
	FontBold = .T., ;
	FontSize = 11, ;
	Caption = "Exit", ;
	MousePointer = 15, ;
	BackColor = RGB(255,0,0), ;
	Name = "Command2"

PROCEDURE Init
	with this
	.backstyle=1
	.borderwidth=1
	.backcolor=rgb(0,255,0)
	.top=1
	.left=(thisform.width-.width)/2

	for i=1 to .controlcount
	if lower(.controls(i).class)=="image"
	bindevent(.controls(i),"mouseEnter",thisform,"my1")
	bindevent(.controls(i),"mouseLeave",thisform,"my2")
	endi
	endfor

	endwith
ENDPROC

PROCEDURE image1.Click
	thisform.yexpand(thisform.container1)
ENDPROC

PROCEDURE image2.Click
	thisform.yexpand(thisform.container2)
ENDPROC

PROCEDURE command1.Click
	thisform.ycollapse()
ENDPROC

PROCEDURE image3.Click
	thisform.yexpand(thisform.container3)
ENDPROC


PROCEDURE image4.Click
	thisform.yexpand(thisform.container4)
ENDPROC


PROCEDURE command2.Click
	thisform.release
ENDPROC
ENDDEFINE
*
*-- EndDefine: ymenu

DEFINE CLASS ycont AS container
Top = 120
Left = 36
Width = 312
Height = 60
BackStyle = 1
BorderWidth = 0
BackColor = RGB(0,0,0)
Name = "Container1"


ADD OBJECT image1 AS image WITH ;
	Stretch = 2, ;
	Height = 48, ;
	Left = 10, ;
	Top = 5, ;
	Width = 48, ;
	Name = "Image1"

ADD OBJECT image2 AS image WITH ;
	Stretch = 2, ;
	Height = 48, ;
	Left = 70, ;
	Top = 5, ;
	Width = 48, ;
	Name = "Image2"

ADD OBJECT image3 AS image WITH ;
	Stretch = 2, ;
	Height = 48, ;
	Left = 133, ;
	Top = 5, ;
	Width = 48, ;
	Name = "Image3"

ADD OBJECT image4 AS image WITH ;
	Stretch = 2, ;
	Height = 48, ;
	Left = 190, ;
	Top = 5, ;
	Width = 48, ;
	Name = "Image4"

ADD OBJECT image5 AS image WITH ;
	Height = 48, ;
	Left = 246, ;
	Top = 5, ;
	Width = 48, ;
	Name = "Image5"

PROCEDURE Init
	with this
	.backstyle=0
	.borderwidth=1
	.setall("mousepointer",15,"image")
	.setall("stretch",2,"image")
	.top=-.height-10
	.left=(thisform.width-.width)/2
	.setall("stretch",2,"image")
	.setall("Width",48,"image")
	.setall("height",48,"image")
	.setall("top",0,"image")
	.height=65
	endwith
ENDPROC

ENDDEFINE
*
*-- EndDefine: ycont


A container as menu and 4 containers as submenus.images are populated from web (internet connected)
A container as menu and 4 containers as submenus.images are populated from web (internet connected)

A container as menu and 4 containers as submenus.images are populated from web (internet connected)

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


*11*created on wednesday 20 of december 2017
*this is a search cool class as Firefox does.its a container as  search class.
*the search class is composed with a textbox,a png icon 32x32 and a label.play on visibility to make the textbox appear or disappear with label visiblity.
*the  container have backstyle property opaque
*added a grid with hilighting by searching interactively in textbox(if the grid.column contains the textbox value, it highlight the corresponding cell.
*the search is with operator $ (can extend to operator = or even ==).
*i assigned a shortcut menu to the search icon(click to fire it).i used 2 menu item for backcolor and autocomplete....can customize....
*i added by default an option of autocomplete textbox (browse historic alphabetically in textbox ).if want to turn off this option make textbox.autocomplete=0 (this option is added in contextuel menu below)
*This class can be applied on any text searching(here on a grid)

publi oform
oform=newObject("yform")
oform.show
read events
retu

define class yform as form
width=650
height=480
showWindow=2
Autocenter=.t.
caption="A search class running on a grid.type any string to search.the grid highlights interactively"
name="form1"

add object ysearch1 as ysearch with ;
backcolor=rgb(255,255,255),;
backstyle=1,;
borderwidth=0,;
left=40,;
top=40,;
name="ysearch1"

add object grid1 as grid with ;
Anchor=15,;
left=5,;
top=100,;
width=600,;
height=300,;
gridlines=0,;
deletemark=.t.,;
name="grid1"

procedure grid1.init
sele * from home(1)+"samples\data\customer" into cursor ycurs
with this
.recordsource="ycurs"
.recordsourcetype=1
endwith
endproc

procedure ydin
with thisform.grid1
For Each oCol As Column In .Columns  foxObject
  If Type(oCol.ControlSource)="C"
	oCol.DynamicBackColor="IIF(UPPER(ALLTRIM(m.thisform.ysearch1.text1.Value))$ UPPER(ALLTRIM("+oCol.ControlSource+")),rgb(173,255,47),rgb(255,255,255))"
  Else
	oCol.DynamicBackColor=""
  Endif
Next
Locate
.Refresh
endwith
endproc

procedure destroy
clea events
endproc

enddefine
*endDefine yform

*
DEFINE CLASS ysearch AS container
Top = 40
Left =40
Width = 258
Height = 40
BackStyle = 1
Backcolor=rgb(255,255,255)
BorderWidth = 0
Name = "ysearch"

ADD OBJECT image1 AS image WITH ;
	Stretch = 2, ;
	BackStyle = 0, ;
	Height = 32, ;
	Left = 2, ;
	Top = 2, ;
	Width = 32, ;
	Name = "Image1"
	
ADD OBJECT text1 AS textbox WITH ;
  autocomplete=1,;
	BackStyle = 0, ;
	BorderStyle = 0, ;
	Height = 27, ;
	Left = 33, ;
	Top = 4, ;
	Width = 216, ;
	Name = "Text1"

ADD OBJECT label1 AS label WITH ;
	FontSize = 10, ;
	BackStyle = 1, ;
	BorderStyle = 0, ;
	Caption = " Search  for. ..", ;
	Height = 26, ;
	Left = 26, ;
	Top = 4, ;
	Width = 194, ;
	ForeColor = RGB(209,209,209), ;
	Name = "Label1"

PROCEDURE Init
	with this
	.backstyle=1
	.borderwidth=1
	.backcolor=rgb(255,255,255)
	.left=40
	.top=40
	.text1.setfocus
	endwith
ENDPROC

PROCEDURE text1.InteractiveChange
	If !Empty(This.Value)
		This.Parent.label1.visible=.f.
	Else
		This.Parent.label1.visible=.t.
	Endif

if vartype(thisform.grid1)="O"
thisform.ydin()
endi
ENDPROC

PROCEDURE image1.Click
	this.parent.text1.enabled=.t.
	This.Parent.text1.SetFocus
ENDPROC

PROCEDURE image1.Init
	with this
	.mousepointer=15
	.backstyle=1
	.stretch=2
	.width=25
	.height=25
	.top=4
	.left=4
	endwith
	*this 3 images of the search icon png appearing randomly
	local m.myvar1,m.myvar2,m.myvar3
	TEXT TO m.myvar  PRETEXT 7 noshow
	iVBORw0KGgoAAAANSUhEUgAAACAAAAAgCAYAAABzenr0AAAC1klEQVRYhbXWT2geRRjH8U+ClCJSRIpIkawtCD0olFChNRVde7B60YsehBz0ontT8aYgpagUoYKgK95DpaJCEUVFB7Wo4J+WEjyFmJVQihQpJRQRCR5mXjJJ3n3z7mve32mf2Zl5vrsz88xvQovKqtmPJzCDKdyAFSwg4Eyoiytt44fVRJ/EU3gTj2FywNi/8RaOh7q4vi0AZdUcw2nc3GGO3/BoqIuF/wVQVs0j+Bg7svdfYA4XcR234RCewv6s3yXMhLpYGgmgrJp9OI9d2YSzoS6+7jeorJpJPIeT4t6AnxPEP10Aemv89obkM23JIdTFaqiLU3gc/6bmg3i2S3KYKKtmGr+keBVlqItvh52grJoTeDmD39vlL0xiNovPdkme9Dr+TM978ECXwZO4N4tPd0wuHcEzWdP9XQFuz+JfuwIknc+e93UF2JnF10YEyNf8pq4AK1l8y4gA+UestPZqAVjK4ukRAe7Jnhe7AnyfxbNtHdtUVs0u8dLq6buuAHPi+Ydj6T7ooles3R2X0FrA+gKEupjHR1nbXFk1B4YZXFbN02JJ7unVrqW4dxfsEY/Sran9Gp7B+6Eu+iW+EcfxgrVyvog7Q12sbhqwFUCa9Ag+s/4YXcAHmMdV8TY8jCcz2Fyvhbp4aSSABHEIH4oldVgtW1/M5sWjeE5ckquDBq9zPKEufsTdeEd0PIN0Bc9jL97N2u8SPcOL+CE5rFZtsmQ9lVWzW7Rl94mecIdoShbxFT7pWbHkD35P/TZqCUdDXfStD60AXVVWzU+iJ+inP8RrfhPEINPZVecGvJtCSM5rbAAncXkIiDvGAhDq4jIexl9bQHyTQ2znHxDq4gIeEmvGIIjQOx3btglzlVVzEJ8bfL0v4PBYABLENL7cAuK9sQEkiAMJYndLl+Vt3QMblfbEUWuueaN2jhUgQVwUnfJyn9dnx7oEudKufwMPiqfvU1T/Ae+yy12f0SBjAAAAAElFTkSuQmCC
	endtext
	text to m.myvar1 pretext 7 noshow
	iVBORw0KGgoAAAANSUhEUgAAACAAAAAgCAYAAABzenr0AAAC1UlEQVRYhbXWTWgdVRjG8V+CDEWkiBSRImFaELpQKKFCaxRHu7C60Y0uhCx0o+5U3ClIEZVSqCAo4j5UKioUUVQ0oxYV/GgpwVWIg4RSpEgpocggwcU5l5zk3rm555r7rOY9cz7+M+ec932mdKipigN4AnOYwQ1YwzIWcaas2ytd40fV1ICFZ/AWHsP0kLH/4G0cL+v2+o4ANFVxDKdxc8Ycv+PRsm6X/xdAUxWP4BMUyfsvsYCLuI7bcBhP4UDS7xLmyrptxgJoqmI/zmN3MuF8WbffDBrUVMU0nscJ4WzALxGizQHo7fE7Wxaf61ocyrpdL+v2FB7Hv7H5EJ7NWRymmqqYxa8xXscDZd1+N+oETVW8hlcS+H05f2Ea80l8NmfxqDfxV3zeiypn8DTuSeLTmYuLV/BM0nR/LsDtSfxbLkDU+eR5fy7AriS+NiZAuuc35QKsJfEtYwKkH7HW2asDoEni2TEB7k6eV3IBfkji+a6OXWqqYrdQtHr6PhdgQbj/cCzWgxy9aqN2XEJnAhsIUNbtEj5O2haaqjg4yuCmKp4WUnJPr+em4l4t2CtcpVtj+zU8gw/Kun++pipuxHG8aCOdr+COsm7X+wZsBxAnvRef23yNLuBDLOGqUA2P4MkENtUbZd2+PBZAhDiMj4SUOqpWbU5mS8JVPCdsydVhgzc5nrJuf8JdeFdwPMN0BS9gH95L2u8UPMNL+DE6rE71WbKemqrYI9iy+wRPWAimZAVf49OeFYv+4I/Yr28qHC3rdmB+6ATIVVMVPwueYJD+FMp8H8Qw05mrc0PezWAxOq+JAZzA5REgyokAlHV7GQ/j720gvk0hdvIPKOv2Ah4ScsYwiMXe7dixQ5iqqYpD+MLw8r6MIxMBiBCz+GobiPcnBhAhDkaIPR1dVnf0DGxVPBNHbbjmrdo1UYAIcVFwyqsDXp+d6Bakiqf+JB4Ubt9neO4/LujK+EKJZ8QAAAAASUVORK5CYII=
	endtext
	text to m.myvar2 pretext 7 noshow
	iVBORw0KGgoAAAANSUhEUgAAACAAAAAgCAYAAABzenr0AAAC1UlEQVRYhbXWTWgdVRjG8V+CDEWkiBSRImFaELpQKKFCaxRHu7C60Y0uhCx0o+5U3ClIEZVSqCAo4j5UKioUUVQ0oxYV/GgpwVWIg4RSpEgpocggwcU5l5zk3rm555r7rOY9cz7+M+ec932mdKipigN4AnOYwQ1YwzIWcaas2ytd40fV1ICFZ/AWHsP0kLH/4G0cL+v2+o4ANFVxDKdxc8Ycv+PRsm6X/xdAUxWP4BMUyfsvsYCLuI7bcBhP4UDS7xLmyrptxgJoqmI/zmN3MuF8WbffDBrUVMU0nscJ4WzALxGizQHo7fE7Wxaf61ocyrpdL+v2FB7Hv7H5EJ7NWRymmqqYxa8xXscDZd1+N+oETVW8hlcS+H05f2Ea80l8NmfxqDfxV3zeiypn8DTuSeLTmYuLV/BM0nR/LsDtSfxbLkDU+eR5fy7AriS+NiZAuuc35QKsJfEtYwKkH7HW2asDoEni2TEB7k6eV3IBfkji+a6OXWqqYrdQtHr6PhdgQbj/cCzWgxy9aqN2XEJnAhsIUNbtEj5O2haaqjg4yuCmKp4WUnJPr+em4l4t2CtcpVtj+zU8gw/Kun++pipuxHG8aCOdr+COsm7X+wZsBxAnvRef23yNLuBDLOGqUA2P4MkENtUbZd2+PBZAhDiMj4SUOqpWbU5mS8JVPCdsydVhgzc5nrJuf8JdeFdwPMN0BS9gH95L2u8UPMNL+DE6rE71WbKemqrYI9iy+wRPWAimZAVf49OeFYv+4I/Yr28qHC3rdmB+6ATIVVMVPwueYJD+FMp8H8Qw05mrc0PezWAxOq+JAZzA5REgyokAlHV7GQ/j720gvk0hdvIPKOv2Ah4ScsYwiMXe7dixQ5iqqYpD+MLw8r6MIxMBiBCz+GobiPcnBhAhDkaIPR1dVnf0DGxVPBNHbbjmrdo1UYAIcVFwyqsDXp+d6Bakiqf+JB4Ubt9neO4/LujK+EKJZ8QAAAAASUVORK5CYII=
	endtext
	rand(-1)
	local m.n
	m.n=INT(3*RAND() +1)
	do case
	case m.n=1
	this.pictureVal=strconv(m.myvar,14)
	case m.n=2
	this.pictureVal=strconv(m.myvar1,14)
	case m.n=3
	this.pictureVal=strconv(m.myvar2,14)
	endcase
ENDPROC

PROCEDURE text1.Init
	with this
	.fontsize=11
	.top=4
	.left = .parent.image1.left + .parent.image1.width+1
	.width=.parent.width-.left-8
	.height=.parent.height-8
	.zorder(1)
	.enabled=.f.
	endwith
ENDPROC

PROCEDURE label1.Init
	with this
	.fontsize=11
	.forecolor=rgb(95,95,95)
	.backcolor=rgb(255,255,255)
	.top=.parent.text1.top
	.left=.parent.text1.left
	.width=.parent.text1.width
	.height=.parent.text1.height
	.zorder(0)
	endwith
ENDPROC	

PROCEDURE label1.Click
	this.parent.text1.enabled=.t.
	This.Parent.text1.SetFocus
ENDPROC

procedure image1.click  && popup to customize
SET COLOR OF SCHEME 1 TO N+/w*,B+/W+*,,,,G/BG+ 
DEFINE POPUP raccourci SHORTCUT RELATIVE FROM MROW(),MCOL() Color  Scheme 1
DEFINE BAR 1 OF raccourci PROMPT "change colors" ;
	PICTURE  home(1)+"graphics\icons\misc\misc15.ico"
DEFINE BAR 2 OF raccourci PROMPT "no autocomp" ;
	PICTURE  home(1)+"graphics\icons\misc\circ1.ico"
DEFINE BAR 3 OF raccourci PROMPT "border" ;
	PICTURE home(1)+"graphics\icons\misc\circ2.ico"
DEFINE BAR 4 OF raccourci PROMPT "item3" ;
	PICTURE  home(1)+"graphics\icons\misc\circ3.ico"
ON SELECTION BAR 1 OF raccourci _screen.activeform.ysearch1._53519svip()
ON SELECTION BAR 2 OF raccourci _screen.activeform.ysearch1.text1.autocomplete=0
ON SELECTION BAR 3 OF raccourci _screen.activeform.ysearch1.borderwidth=iif(_screen.activeform.ysearch1.borderwidth=1,0,1)
ACTIVATE POPUP raccourci
endproc

PROCEDURE _53519svip  && the white color is better
with _screen.activeform
.ysearch1.backcolor=getcolor()
.ysearch1.label1.backcolor=.ysearch1.backcolor
endwith
endproc

ENDDEFINE
*
*-- EndDefine: ysearch


Working on VFP objects dynamically - partI
Working on VFP objects dynamically - partI
Working on VFP objects dynamically - partI

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


*12*  created on thursday 06 of february 2017
*from http://www.sweetpotatosoftware.com/blog/index.php/2007/12/21/windows-vista-and-the-ms-progressbar-control/
*COMCTL.ProgCtrl.1 activeX control for windows progressbars (author SPS web log).i reproduce the code with small adaptations and to avoid broken site and save this piece of vfp code.

Public oform
oform=Newobject("progressbars")
oform.Show
Return

Define Class progressbars As Form
  Top = -2
  Left = 0
  Height = 355
  Width = 353
  ShowWindow = 2
  MaxButton=.F.
  Caption = "Vista Progress Bar Example"
  Name = "Form1"
  AutoCenter = .T.

  Add Object oleprogress As OleControl With ;
    Top = 25, ;
    Left = 26, ;
    Height = 25, ;
    Width = 300, ;
    Name = "oleProgress", ;
    OleClass = "COMCTL.ProgCtrl.1"

  Add Object timer1 As Timer With ;
    Top = 60, ;
    Left = 168, ;
    Height = 23, ;
    Width = 23, ;
    Name = "Timer1"

  Add Object ycom As CommandButton With ;
    caption="Play It",;
    mousepointer=15,;
    left=100   ,;
    top =60    ,;
    specialEffect=2,;
    autosize=.T.,;
    name="ycom "

  Add Object opgstate As OptionGroup With ;
    AutoSize = .T., ;
    ButtonCount = 3, ;
    BackStyle = 0, ;
    Value = 1, ;
    Height = 65, ;
    Left = 212, ;
    Top = 150, ;
    Width = 71, ;
    Name = "opgState", ;
    Option1.BackStyle = 0, ;
    Option1.Caption = "Normal", ;
    Option1.Value = 1, ;
    Option1.Height = 17, ;
    Option1.Left = 5, ;
    Option1.Top = 5, ;
    Option1.Width = 59, ;
    Option1.AutoSize = .T., ;
    Option1.Name = "Option1", ;
    Option2.BackStyle = 0, ;
    Option2.Caption = "Error", ;
    Option2.Height = 17, ;
    Option2.Left = 5, ;
    Option2.Top = 24, ;
    Option2.Width = 45, ;
    Option2.AutoSize = .T., ;
    Option2.Name = "Option2", ;
    Option3.BackStyle = 0, ;
    Option3.Caption = "Paused", ;
    Option3.Height = 17, ;
    Option3.Left = 5, ;
    Option3.Top = 43, ;
    Option3.Width = 61, ;
    Option3.AutoSize = .T., ;
    Option3.Name = "Option3"

  Add Object spnprogress As Spinner With ;
    Height = 24, ;
    KeyboardHighValue = 100, ;
    KeyboardLowValue = 0, ;
    Left = 150, ;
    SpinnerHighValue = 100.00, ;
    SpinnerLowValue = 0.00, ;
    Top = 115, ;
    Width = 72, ;
    Format = "999", ;
    Name = "spnProgress"

  Add Object chkvertical As Checkbox With ;
    Top = 150, ;
    Left = 92, ;
    Height = 17, ;
    Width = 58, ;
    AutoSize = .T., ;
    Alignment = 0, ;
    BackStyle = 0, ;
    Caption = "Vertical", ;
    Value = .F., ;
    Name = "chkVertical"

  Add Object chksmooth As Checkbox With ;
    Top = 174, ;
    Left = 92, ;
    Height = 17, ;
    Width = 61, ;
    AutoSize = .T., ;
    Alignment = 0, ;
    BackStyle = 0, ;
    Caption = "Smooth", ;
    Value = .F., ;
    Name = "chkSmooth"

  Add Object chksmoothreverse As Checkbox With ;
    Top = 198, ;
    Left = 92, ;
    Height = 17, ;
    Width = 110, ;
    AutoSize = .T., ;
    Alignment = 0, ;
    BackStyle = 0, ;
    Caption = "Smooth Reverse", ;
    Value = .F., ;
    Name = "chkSmoothReverse"

  Add Object chkmarquee As Checkbox With ;
    Top = 222, ;
    Left = 92, ;
    Height = 17, ;
    Width = 66, ;
    AutoSize = .T., ;
    Alignment = 0, ;
    BackStyle = 0, ;
    Caption = "Marquee", ;
    Value = .F., ;
    Name = "chkMarquee"

  Add Object label1 As Label With ;
    AutoSize = .T., ;
    BackStyle = 0, ;
    Caption = "Progress", ;
    Height = 17, ;
    Left = 92, ;
    Top = 119, ;
    Width = 53, ;
    Name = "Label1"

  Add Object label2 As Label With ;
    AutoSize = .T., ;
    BackStyle = 0, ;
    Caption = "%", ;
    Height = 17, ;
    Left = 228, ;
    Top = 119, ;
    Width = 13, ;
    Name = "Label2"

  Add Object label3 As Label With ;
    AutoSize = .T., ;
    BackStyle = 0, ;
    Caption = "Microsoft ProgressBar Control, version 5.0 (SP2)", ;
    Height = 17, ;
    Left = 26, ;
    Top = 6, ;
    Width = 267, ;
    Name = "Label3"

  Procedure ycom.Click

    With Thisform.spnprogress
      For .Value=0 To 100
        Thisform.oleprogress.Value = .Value
        .InteractiveChange()
        Inke(0.15)
      Endfor
      .Value=0
      .interactivechange()
    Endwith

  Endproc

  Procedure setprogressbar
    #Define GWL_STYLE -16
    #Define WM_USER 0x0400
    #Define WS_VISIBLE 0x10000000
    #Define WS_CHILD 0x40000000

    #Define PBM_SETRANGE 0x0401
    #Define PBM_SETPOS 0x0402
    #Define PBM_DELTAPOS 0x0403
    #Define PBM_SETSTEP 0x0404
    #Define PBM_STEPIT 0x0405
    #Define PBM_SETRANGE32 0x0406
    #Define PBM_GETRANGE 0x0407
    #Define PBM_GETPOS 0x0408
    #Define PBM_SETBARCOLOR 0x0409
    #Define PBM_SETBKCOLOR 0x2001
    #Define PBM_SETMARQUEE 0x040A
    #Define PBM_GETSTEP 0x040D
    #Define PBM_GETBKCOLOR 0x040E
    #Define PBM_GETBARCOLOR 0x040F
    #Define PBM_SETSTATE 0x0410
    #Define PBM_GETSTATE 0x0411

    #Define PBS_SMOOTH 0x01
    #Define PBS_VERTICAL 0x04
    #Define PBS_MARQUEE 0x08
    #Define PBS_SMOOTHREVERSE 0x10

    #Define PBST_NORMAL 0x0001
    #Define PBST_ERROR 0x0002
    #Define PBST_PAUSED 0x0003

    *!*    Style = GetWindowLong (Thisform.oleProgress.Object.HWnd, GWL_STYLE)
    Local lnStyle, lnReturn, lnState

    Declare Integer SendMessage In user32 Integer, Integer, Integer, Integer
    Declare Integer SetWindowLong In WIN32API Integer, Integer, Integer
    Declare Integer GetWindowLong In user32 Integer, Integer

    This.timer1.Interval = 0
    This.oleprogress.Value = 0
    This.spnprogress.Value = 0

    m.lnStyle = Bitor(WS_CHILD, WS_VISIBLE)

    If This.chkvertical.Value
      m.lnStyle = Bitor(m.lnStyle, PBS_VERTICAL)
      This.oleprogress.Width = 25
      This.oleprogress.Height = 300
    Else
      This.oleprogress.Height = 25
      This.oleprogress.Width = 300
    Endif

    If This.chksmooth.Value
      m.lnStyle = Bitor(m.lnStyle, PBS_SMOOTH)
    Endif

    If This.chksmoothreverse.Value
      m.lnStyle = Bitor(m.lnStyle, PBS_SMOOTHREVERSE)
    Endif

    If This.chkmarquee.Value
      m.lnStyle = Bitor(m.lnStyle, PBS_MARQUEE)
    Endif

    m.lnReturn = SetWindowLong(This.oleprogress.Object.HWnd, GWL_STYLE, m.lnStyle)

    Do Case
      Case This.opgstate.Value = 1
        m.lnState = PBST_NORMAL
      Case This.opgstate.Value = 2
        m.lnState = PBST_ERROR
      Case This.opgstate.Value = 3
        m.lnState = PBST_PAUSED
    Endcase

    m.lnReturn = SendMessage(This.oleprogress.Object.HWnd, PBM_SETSTATE, m.lnState, 0)
    If This.chkmarquee.Value
      This.timer1.Interval = 100
    Endif
  Endproc

  Procedure timer1.Timer
    *!* Work around as SendMessage does not work
    *!* to set the animation to automatic using:
    *!* m.lnReturn = SendMessage(Thisform.oleProgress.Object.HWnd, PBM_SETMARQUEE, 1, 100)
    Thisform.oleprogress.Object.Value = 0
  Endproc

  Procedure opgstate.InteractiveChange
    Thisform.setprogressbar()
  Endproc

  Procedure spnprogress.InteractiveChange
    Thisform.oleprogress.Value = This.Value
  Endproc

  Procedure spnprogress.Valid
    This.InteractiveChange()
  Endproc

  Procedure chkvertical.Valid
    Thisform.setprogressbar()
  Endproc

  Procedure chksmooth.Valid
    Thisform.setprogressbar()
  Endproc

  Procedure chksmoothreverse.Valid
    Thisform.setprogressbar()
  Endproc

  Procedure chkmarquee.Valid
    Local llNotValue
    m.llNotValue = !This.Value
    Thisform.spnprogress.Enabled = m.llNotValue
    Thisform.chkvertical.Enabled = m.llNotValue
    Thisform.chksmooth.Enabled = m.llNotValue
    Thisform.chksmoothreverse.Enabled = m.llNotValue
    Thisform.opgstate.Option2.Enabled = m.llNotValue
    Thisform.opgstate.Option3.Enabled = m.llNotValue
    If !m.llNotValue
      Thisform.chkvertical.Value = .F.
      Thisform.chksmooth.Value = .F.
      Thisform.chksmoothreverse.Value = .F.
      Thisform.opgstate.Value = 1
      Thisform.Refresh()
    Endif
    Thisform.setprogressbar()
  Endproc
Enddefine


this is windows10 aspect.it seems better on windows vista.

this is windows10 aspect.it seems better on windows vista.

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


*13* created on friday 09 of february 2018
*Windows vista progressbar-just needed developper code of this activeX progressbar

Public oform
oform=Newobject("progressbars")
oform.Show
Return

Define Class progressbars As Form
  Top = -2
  Left = 0
  Height = 90
  Width = 353
  ShowWindow = 2
  MaxButton=.F.
  Caption = "Vista Progress Bar Example"
  Name = "Form1"
  AutoCenter = .T.

  Add Object oleprogress As OleControl With ;
    Top = 25, ;
    Left = 26, ;
    Height = 25, ;
    Width = 300, ;
    Name = "oleProgress", ;
    OleClass = "COMCTL.ProgCtrl.1"

  Add Object ycom As CommandButton With ;
    caption="Play It",;
    mousepointer=15,;
    left=150   ,;
    top =60    ,;
    specialEffect=2,;
    autosize=.T.,;
    name="ycom "

  Procedure ycom.Click
  sys(2002)
   create cursor ycurs( x i)
   for i=1 to 10000
   insert into ycurs values (i)
   endfor
   sele ycurs
   scan
   if mod(recno(),50)=0
   Thisform.oleprogress.object.Value =100*recno()/reccount()
   inke(0.15)
    endi
   endscan
     Thisform.oleprogress.object.Value =0
     sys(2002,1)
  Endproc

  Procedure setprogressbar
    #Define GWL_STYLE -16
    #Define WM_USER 0x0400
    #Define WS_VISIBLE 0x10000000
    #Define WS_CHILD 0x40000000

    #Define PBM_SETRANGE 0x0401
    #Define PBM_SETPOS 0x0402
    #Define PBM_DELTAPOS 0x0403
    #Define PBM_SETSTEP 0x0404
    #Define PBM_STEPIT 0x0405
    #Define PBM_SETRANGE32 0x0406
    #Define PBM_GETRANGE 0x0407
    #Define PBM_GETPOS 0x0408
    #Define PBM_SETBARCOLOR 0x0409
    #Define PBM_SETBKCOLOR 0x2001
    #Define PBM_SETMARQUEE 0x040A
    #Define PBM_GETSTEP 0x040D
    #Define PBM_GETBKCOLOR 0x040E
    #Define PBM_GETBARCOLOR 0x040F
    #Define PBM_SETSTATE 0x0410
    #Define PBM_GETSTATE 0x0411

    #Define PBS_SMOOTH 0x01
    #Define PBS_VERTICAL 0x04
    #Define PBS_MARQUEE 0x08
    #Define PBS_SMOOTHREVERSE 0x10

    #Define PBST_NORMAL 0x0001
    #Define PBST_ERROR 0x0002
    #Define PBST_PAUSED 0x0003

    *!*    Style = GetWindowLong (Thisform.oleProgress.Object.HWnd, GWL_STYLE)
    Local lnStyle, lnReturn, lnState

    Declare Integer SendMessage In user32 Integer, Integer, Integer, Integer
    Declare Integer SetWindowLong In WIN32API Integer, Integer, Integer
    Declare Integer GetWindowLong In user32 Integer, Integer

    This.oleprogress.Value = 0

    m.lnStyle = Bitor(WS_CHILD, WS_VISIBLE)

      This.oleprogress.Height = 25
      This.oleprogress.Width = 300
      m.lnStyle = Bitor(m.lnStyle, PBS_SMOOTH)   &&chksmooth.Value

    m.lnReturn = SetWindowLong(This.oleprogress.Object.HWnd, GWL_STYLE, m.lnStyle)
    m.lnState = PBST_NORMAL
    m.lnReturn = SendMessage(This.oleprogress.Object.HWnd, PBM_SETSTATE, m.lnState, 0)
  Endproc

 procedure init
 this.setProgressbar()
 endproc
Enddefine


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


*14* created on saturday 10 of january 2018
*extract resources images bmp,png,jpg,gif from a VFP executable.
*extracted images are gathered in "extractedResources" folder (in source of this code).
*adapted from original codes in http://www.tek-tips.com/viewthread.cfm?qid=1732378
*all credits to authors (Olaf Doscke & vgulielmus)
*acquire images by reading the string of executable file directly.
*This code is used when resources are lost and only exe is dispoible.

set safe off
Local myrep
m.yrep=Addbs(Justpath(Sys(16,1)))  &&start folder
Set Defa To (yrep)

Local m.ccVFPApp,m.ccImageFolder,m.i,m.lcFilename,m.img,m.lcVFPApp
m.ccVFPApp=Getfile("exe")  &&vfp executable file
If Empty(m.ccVFPApp)
  Return .F.
Endi

m.ccImageFolder=m.yrep+"extractedResources"  &&extracted resources folder.if not exist create it
If ! Directory(m.ccImageFolder)
  Md (m.ccImageFolder)
Endi

m.lcVFPApp = Filetostr(m.ccVFPApp)   &&convert exe to string
************************************
*extract BMPs (if there)
Local  m.lnBMPPosition, m.lcBMPHeader,m.nBMP
m.img=0
m.i=1
m.nBMP=0
Do While .T.
  m.lnBMPPosition = At("BM",m.lcVFPApp,m.i)
  If m.lnBMPPosition=0
    Exit
  Endif
  m.lcBMPHeader = Substr(m.lcVFPApp,m.lnBMPPosition+2 ,4)
  m.lnSize = CToBin(Right(m.lcBMPHeader,4),"4RS")
  m.lcBMPHeader2 = Substr(m.lcVFPApp,m.lnBMPPosition+10 ,4) && bmp header length
  m.lnSize2 = CToBin(Right(m.lcBMPHeader2,4),"4RS")


  If m.lnSize>4 And (Between(m.lnSize2,1,2^16)) && bmp header length probably is bigger than 65536
    m.img=m.img+1
    m.lcFilename = "image"+Padl(m.img,5,"0")+".bmp"
    Strtofile(Substr(m.lcVFPApp,m.lnBMPPosition ,m.lnSize),Addbs(m.ccImageFolder)+m.lcFilename)
    m.nBMP=m.nBMP+1
  Endif
  i = i + 1
Enddo
********************************************
*extract PNGs (if there)
Local m.lnPNGPosition,  m.lcPNGTerm,m.nPNG
m.i=1
m.img=0
m.nPNG=0
Do While .T.
  m.lnPNGPosition = At(Chr(0x89)+"PNG"+Chr(13)+Chr(10)+Chr(26)+Chr(10),m.lcVFPApp,i)
  If m.lnPNGPosition=0
    Exit
  Endif
  m.lcPNGTerm = At("IEND"+Chr(0xAE)+Chr(0x42)+Chr(0x60)+Chr(0x82),Substr(m.lcVFPApp,m.lnPNGPosition ))
  If m.lcPNGTerm>0
    m.img=m.img+1
    m.lcFilename = "image"+Padl(m.img,5,"0")+".PNG"
    Strtofile(Substr(m.lcVFPApp,m.lnPNGPosition ,m.lcPNGTerm+8),Addbs(m.ccImageFolder)+m.lcFilename)
    m.nPNGP=m.nPNG+1
  Endif
  i = m.i + 1
Enddo
*****************
*extract JPGs (if there)
Local m.lnJPGPosition,  m.lcJPGTerm,m.nJPG
m.i=1
m.img=0
nJPG=0
Do While .T.
  m.lnJPGPosition = At(Chr(0xFF)+Chr(0xD8)+Chr(0xFF),m.lcVFPApp,i)
  If m.lnJPGPosition=0
    Exit
  Endif
  m.lcJPGTerm = At(Chr(0xFF)+Chr(0xD9),Substr(m.lcVFPApp,m.lnJPGPosition ))
  If m.lcJPGTerm>0
    m.img=m.img+1
    m.lcFilename = "image"+Padl(m.img,5,"0")+".JPG"
    Strtofile(Substr(m.lcVFPApp,m.lnJPGPosition ,m.lcJPGTerm+2),Addbs(m.ccImageFolder)+m.lcFilename)
    m.nJPG=m.nJPG+1
  Endif
  i = m.i + 1
Enddo
*****************************
*extract GIFs if there
Local  m.lnGIFPosition, m.lcGIFTerm ,m.nGif
m.i=1
m.img=0
m.nGif=0
Do While .T.
  m.lnGIFPosition = At("GIF",m.lcVFPApp,i)
  If m.lnGIFPosition=0
    Exit
  Endif
  m.lcGIFTerm = At(Chr(0)+Chr(0x3B),Substr(m.lcVFPApp,m.lnGIFPosition ))
  If m.lcGIFTerm>0
    m.img=m.img+1
    m.lcFilename = "image"+Padl(m.img,5,"0")+".GIF"
    Strtofile(Substr(m.lcVFPApp,m.lnGIFPosition ,m.lcGIFTerm+2),Addbs(m.ccImageFolder)+m.lcFilename)
    m.nGif=m.nGif+1
  Endif
  i = m.i + 1
Enddo
*****************************
local m.myvar
text to m.myvar pretext 7 textmerge noshow
         Extracted resources
*images BMP :<<m.nBMP>>
*images PNG :<<m.nPNG>>
*images JPG :<<m.nJPG>>
*images GIF :<<m.nGif>>
*Total extracted=<<m.nBMP+m.nPNG+m.nJPG+m.nGIF>>
endtext

messagebox(m.myvar,0+32+4096,"Extracted resources")
set safe on

*see the resources extracted.
Run/N explorer  &ccImageFolder

Retu


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


*15* created on saturday 10 of february 2018
*https://stackoverflow.com/questions/36213858/woodys-numerical-keyboard-in-vfp
*answering a question of a user on woody'S keyboard.this is the code:

*Begin code
                set safe off
        set defa to addbs(justpath(sys(16,1)))

        publi m.myvar1,m.myvar2,m.myvar3
        text to m.myvar1 noshow
        /9j/4QFFRXhpZgAASUkqAAgAAAAIABIBAwABAAAAAQAAABoBBQABAAAAbgAAABsBBQABAAAAdgAAACgBAwABAAAAAgAAADEBAgAdAAAAfgAAADIBAgAVAAAAmwAAABMCAwABAAAAAgAAAGmHBAABAAAAsAAAAAAAAAAsAQAAAQAAACwBAAABAAAAQWRvYmUgUGhvdG9zaG9wIENTIE1hY2ludG9zaAAyMDA1OjEyOjE1IDEyOjU5OjI1AAAHAACQBwAEAAAAMDIyMAGRBwAEAAAAAQIDAACgBwAEAAAAMDEwMAGgAwABAAAAAQAAAAKgBAABAAAARgAAAAOgBAABAAAARgAAAAWgBAABAAAACgEAAAAAAAACAAEAAgAFAAAAKAEAAAIABwAEAAAAAwAAAAAAAAABAQEBAAAAAAAAAAAAAAAAAAAAAAD/wAARCABGAEYDASIAAhEBAxEB/9sAhAAFAwMEAwMFBAQEBQUFBgcNCAcHBwcQCwwJDRMQFBMSEBISFRceGRUWHBYSEhojGhwfICEiIRQZJSckICceISEgAQUFBQcGBw8ICA8gFRIVFSAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICD/xAGiAAABBQEBAQEBAQAAAAAAAAAAAQIDBAUGBwgJCgsQAAIBAwMCBAMFBQQEAAABfQECAwAEEQUSITFBBhNRYQcicRQygZGhCCNCscEVUtHwJDNicoIJChYXGBkaJSYnKCkqNDU2Nzg5OkNERUZHSElKU1RVVldYWVpjZGVmZ2hpanN0dXZ3eHl6g4SFhoeIiYqSk5SVlpeYmZqio6Slpqeoqaqys7S1tre4ubrCw8TFxsfIycrS09TV1tfY2drh4uPk5ebn6Onq8fLz9PX29/j5+gEAAwEBAQEBAQEBAQAAAAAAAAECAwQFBgcICQoLEQACAQIEBAMEBwUEBAABAncAAQIDEQQFITEGEkFRB2FxEyIygQgUQpGhscEJIzNS8BVictEKFiQ04SXxFxgZGiYnKCkqNTY3ODk6Q0RFRkdISUpTVFVWV1hZWmNkZWZnaGlqc3R1dnd4eXqCg4SFhoeIiYqSk5SVlpeYmZqio6Slpqeoqaqys7S1tre4ubrCw8TFxsfIycrS09TV1tfY2dri4+Tl5ufo6ery8/T19vf4+fr/2gAMAwEAAhEDEQA/APeLixh+KFs19fyNJauSbeAt8iL246Z9652T4LaSznbYxY/3K0fhFM7+F7JSf+WYFenQwLtHy1wwhGrFSlufc4zG18orSw9CVoJ2SPH/APhSemf8+EX/AHxR/wAKU0sf8uEX/fFezCBMfdFMeBccKKr6rDscn+s+N/mZ40fgxpK9bKEf8App+D+iL1tYB/wGvW7m3XB+UVjX1uozwKl4eC6HVRz/ABlTRzZ5w3wo0FOtvBx/siszW/hloUNlI8dtASq54Fd3fQgE8CsLU1xbTDHGw1jKnFaWPYw+PxUmm6jPNvBn7Qd78G9WutN1FrnVNFeP9xbtJlreQEfcJzhSM5XpnGMc563/AIbo0H/oXbv/AL/D/CvnP4r8azx/eNcXk1yxxNSmuWL0PbzDJcvxNX2tWknJpXd2vyaPuj4PH/imrH/cFerwkbB9K8l+EJx4Xsz6RivUbe4Gwc16WG+BHwnE0b42dv5mXwRjimtjtUInGKZJcDHWum580oO4y4IwRWNfkYNXrm5GOtYt9cjkZrObPTwtN3MnUCMmsDVT/o0v+4a172cEmsTUpP8ARpf9w1yTPqcJCyR8tfFb/kMf8CNcXXY/FVgdYP8AvGuMyK8yW59tiXaS9EfcXwpfZ4RtT6RCu5ttSGwc9q8/+GkmzwVAfSEVrQaphR81epSlywR8RmuF9ti6v+I7RdSX+9UcmpDHWuWGrHH3qa+qEj71a+0PKWW6m5c6iCDzWTd3ucjNUJdRz3qnLdluAazlM76GC5SW5uMmszUJM2sv+4akkm7Z5qnfP/osoH901i2etSpcp8yfFE51g/7xrjuK674nnOrn/eNcfXA9z6XFu00vJH2v8PWx4Gh/64/0qFLwgdaz/AHiCzXwbFA8yq3lY5PtUYvrcHAmT867VJcqPHnh5PFVW1vI2VvT60fbD6/rWQL6D/nqn/fVKL+DtKn/AH1S5hfVvI1DdZ70wzk98Vni/gx/rk/MUv2yA/8ALZP++qOYaoW6Fwy56VBeEfZZf9w1ELuDoJk/76qHUNRtobGZnnTAQ/xUXKVKV9EfOHxMP/E3P+8a5HNdL8Qr2O51ZjGwIDGuY3iuS1z08dJKrZ9kfS37Q3gm/wDg5qLahpt5DLouozM1tBkiS3J5KdMFRng5zjjHGT403xJv8/xfnX0p+3X/AMizoX/Xd/5Cvj49a3xUVCq1E83Iswr1stpVKju7NX9G0vwR1o+JWodPm/OlHxL1D1f865EUo6VzXZ6v1uodcPiXqA7v+dH/AAszUPV/zrkaKLsaxdQ6/wD4WbqHq/51XvviJf3MBjLOARjrXMU1/u07sUsXVS0Pqb9mn9mfTPFWjnxl4ya31G1voSllZIW+T5hl3PHzfLgAZGCefT2P/hl/4W/9CvD/AN/H/wAaX9mH/kiXh/8A65N/6Ga9Lr2sPQp+zTa6H5ZnWc4+OPqwhVaSk0knbb0P/9k=
        endtext
        strtofile(strconv(m.myvar1,14),'img1.jpg')

        text to m.myvar2 noshow
        /9j/4AAQSkZJRgABAQEBLAEsAAD/2wBDAAYEBAQFBAYFBQYJBgUGCQsIBgYICwwKCgsKCgwQDAwMDAwMEAwODxAPDgwTExQUExMcGxsbHCAgICAgICAgICD/2wBDAQcHBw0MDRgQEBgaFREVGiAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICD/wAARCACLAEYDAREAAhEBAxEB/8QAHAABAAIDAQEBAAAAAAAAAAAAAAUGAQMEAgcI/8QAPxAAAAUCAwMEEAQHAAAAAAAAAAECBBIDBQYRIRRyshZBYXETIjEyNVFSVFVikZKTobHCM0KBwRUjRHOi0fD/xAAbAQEAAgMBAQAAAAAAAAAAAAAABAUBAwYCB//EADcRAAEDAgAKCAUEAwAAAAAAAAABAhEDBAUSMTIzQXGBsfATFBUhUVKRkiNCU6HRIjRhwQaC4f/aAAwDAQACEQMRAD8A/TtxuGykinTR2Z1W0o0S0zy7qlHzJTzmIV5eJRTuSXuyJzqQ30KGP3r3NTKvOsrt3uzFnmV2e1HDg/6JqZ00J/RJkfvqHM3uEEbpnq53lb3J9v7Utba2e/RNRrfF3evOxCE5W2XmtdTLmzrqFP2tR+mvuUseza3nT2mOVtm9FL+OoO1qP019yjs2r509o5W2b0Uv46g7Wo/TX3KOzavnT2jldZvRa/jqDtaj9Nfco7Nq+dPaekYssJqLsltqoT5SKyjV9U/UZbhWhrY5P9l/4YXBtbU9PQsdtuR1qRuLQ7U8pI/EYOFZrLdWrtyPxSzIxf2d+6Mak7HTW12XcuX1lCqr0MVcWq3FXzJ+MnpCk8zeUHjdNeiZxPQyMslJMtDSouYyMdJb3DazMZuTnuUrKtJWOhSsXS6m1bvrqWrirUNqzz/KmmZp4kqWOTv7zFx6utVxW7E7vypcW9tjubT1ImMu/lEPn1Q6lSoqpUUa1rPNSj1MzMca6VWVynUNhEhMh5gPMGZEAgSIBAkQCBIiECTptz1zb3aHTc8lo5uYy50n0GN1vWdSejm5UNNek2o3FdkPorS6NmztLvOLO40eymXdyqoiWfWpKsj6h3NletpvxvkqNnekcUX7HLVLdzm4vzMWN3PErF9UZ2dknx1a5n1zP/Y5y+X4TdruJb2afFdsbwK/AVEFnIgECRAIEiAQJEAgzIgECRAIElhrHnhu256mSqpf5GLd37Zm/iVbf3D9xi7a2tn/AHK/GYXejbtdxFtpHbE4ENAVsE+RAIEiAQJEAgSIBAkQCBIgMQZkmHGlgYF61TiMWT/27N/EgM079x6f621rv1uMx6uNG3a7ieaOkdsTgRsBBgmSYgECREIEiIQJEQgSIBAkQCBJIO/ArIvWqcRiZU0LN5Fp6V242OdWDffq8Zj1VzE2rxPLM9dicDigI0EiRAIEiAQJEAgSIBAkQCBIgECTpfeCmhesv6jdW0Td5qo6R242q1ZUt+rxmNjs1Nq8TWmeuxOBpgNUGyRAIEmIBAkQCDMiAQJEAgSIBAkzcdGDYulX1GbjRtMUM9TfT1ao36nGY2pm714mt2d6cDEBiBIgECRAIEiAQJEAgSIBAkQCBJouujWgXSoarnNQ22+cp0tNW5by+Mxvp5N68TTUzvTgbYD3B4kQCBIgECRAIEiAxAkQCBIgECTgvH4VIukxGusiEm2yqddu1pHvL4zG+hk3rxNFfLz4HXAb4NEiAQJEAgSIBAkQCDMiIQJEQgSRF7/IXT+wgXhOtDts+qKm8rjMSbXXt/sj3XPoSMBMgiSIBAkQCBIgECRAYgSIBAkQCBJA37SqRdP7EKq9ylnZ5DusGvZt4+JQl2WvnWpGvNRLwE+CDIgECRAIEiAQJEAgSIBAkQCBJWMQ6OzL/u9IUt/nlxZZpI4a1U46/uUJmD8rudakS/1E7AWcFdIgECRAIEiAQJEAgSIBAkQCBJUcSaXBZdXCQ5/CGk58C8scwksJ61XfX9yhNwZldzrUiYSyNLJAXEFTJiAQJEAgzIgECRAIEiAQJEAgSUnE/hWqW7wJHNYS0q86kOhwfo051kpgzWu96/uUJ2CM5/OtSFhXI0tMBeQU0iAQJEAgSIBAkQCBIgECRAIElBxVpe65bvAkcphPTru4IdNg7QpzrUksPVEsMTO2FTtZrqU0Z+MlZp9pCdZL0N2+mviqffuIl83pLdr08EUucR0UFBIiECRAIEiAQJEAgSIBAkwaSLU+4ECT5/slbEN/dE1yyyNZGZ5dok0oL2jladu69uHIzbu7kOo6RLWg3G51k9jbDjirVK7sEmddJFtCEd8ce9WnpLnF9/kOCXOXp6WdrT+0KzBN81E6J+TV+DTZMdtV000bnnTqlptBFmlXWRakYrrLDbVSKvcvibLvA7kWafengTxYhsJlnt1H3yFr1+h52+pW9SreVTPKCxefUffIOv0PO31MdSreVfQxygsXn9H3yDr9Dzt9R1Kt5VHKCxef0ffIOv0PO31HUq3lU81MSWCmmSn1Iy9U5H7E5mMOwjbp86HpLCuvyqVa/YuqXEv4faqa4Vu1UrL+Yv1UpLuEYo73Cq1vh0UXv9V2FzZ4MSl+uouT0Qs+EcPKtDJR18jeuMlVstSSRd6jPoz1HWYDwX1Wn+rSOy/x/BT4Svenf3ZqZPyTwuytK9ibD9nrM3D1bVO1JTn2VOaDM8+6cTLP9RRYXwZbvpuqK1MfxycMpaWF7Va9GI79JQdha+R8zHD9XZ4HTdK4bC18j5mHVmeA6Vw2Fr5HzMOrM8B0rhsLXyPmYdWZ4DpXHuhb2iq9NKkaKURHqfj6x7p2tNXIkazy+s6D6Za7JarcnNm2TSUou2XqpXVJWZ5D6JZ4PoUE+G1EX7+q95yFxd1KueskgJxGP//Z
        endtext
        strtofile(strconv(m.myvar2,14),'img2.jpg')

        text to m.myvar3 noshow
        /9j/4AAQSkZJRgABAQEASABIAAD/2wBDABALCwwMDBENDREYEA4QGBwVEREVHCEZGRkZGSEgGRwcHBwZICAlJygnJSAwMDQ0MDBAQEBAQEBAQEBAQEBAQED/2wBDAREQEBITEhYSEhYWEhUSFhwWFxcWHCgcHB0cHCgxJSAgICAlMSwvKCgoLyw2NjExNjZAQD9AQEBAQEBAQEBAQED/wAARCABGAEYDASIAAhEBAxEB/8QAGgABAQADAQEAAAAAAAAAAAAAAAMCBAYFAf/EADIQAAECAQkHAwMFAAAAAAAAAAABAgMEBRETFTRRcrEGEjGBktHwISMyQVKhIkJhccH/xAAZAQACAwEAAAAAAAAAAAAAAAAAAwECBQT/xAAiEQACAQIGAwEAAAAAAAAAAAAAAQIDEQQSMUFRcRMzkSH/2gAMAwEAAhEDEQA/AOwr4cvarGL6etB4UrmpGxFpVepe5CZpU9sCEqLxYmheUSp7n0qopyO+nQs9mmtzXsxmLup3cWYzF3U7uZV7hXuK5h/iXEfhjZjMXdTu4sxmLup3cyr3CvcGYPEuI/DGzGYu6ndzUlUhhs+7qd3N2vca0peruJFyVSjvGPwzmKfUmqO6TyuI5ZG9u9D3l3lY9FT0Sn6LSDmZ/WiA1U47/wDigdHQz68YxqNJHRzTdoORuheL8iE03aDkboXi/ISzRht0jAAFRgAAACMfgWIx+AEnO7QXdudNFA2gu7c6aKDohoZWK9r6Okmm7QcjdC8X5EJpu0HI3QvF+QlmhDbpGAAKjAAAAEY/AsRj8AJOd2gu7c6aKBtBd2500UHRDQysV7X0dJNN2g5G6F4vyNGbI+7JoX8MRF5Gw+UIqiWaMF+LpGYJVyCuQqMKglXIK5AAqRj8D7XISixEVAA8HaC7tzpooE+Uvgta1KV3qfwDohoZWJ9j6PXnrdmicYsn4wonvQqP2teq/pX+lpNG1WYO85gFGlcfTnLIv0WozB3nMWozB3nMAixfPLkWozB3nMWozB3nMALBnlyLUZg7zmYrObF+jvOYAWDPLk97ZCQwJxiRpbKG78KH7MOGv3ejnOX8UAAatDgqNuTP/9k=
        endtext
        strtofile(strconv(m.myvar3,14),'img3.jpg')


        publi yform
        yform=newObject("asup")
        yform.show
        read events
        retu
        *
        DEFINE CLASS asup AS form
            Height = 222
            Width = 252
            AutoCenter = .T.
            Caption = "Sampleform for Virtual Keyboard"
            *-- Reference for the Keyboard
            okeyboard = .NULL.
            Name = "Form1"

            ADD OBJECT label1 AS label WITH ;
                AutoSize = .T., ;
                BackStyle = 0, ;
                Caption = "Enter Value:", ;
                Height = 17, ;
                Left = 24, ;
                Top = 36, ;
                Width = 68, ;
                Style = 3, ;
                Name = "Label1"

            ADD OBJECT text1 AS textbox WITH ;
                FontName = "Courier New", ;
                Alignment = 3, ;
                Value = 0, ;
                Height = 23, ;
                InputMask = "999,999.999", ;
                Left = 100, ;
                SelectOnEntry = .T., ;
                Top = 33, ;
                Width = 128, ;
                Name = "Text1"

            ADD OBJECT label2 AS label WITH ;
                AutoSize = .T., ;
                BackStyle = 0, ;
                Caption = "Enter Value:", ;
                Height = 17, ;
                Left = 25, ;
                Top = 68, ;
                Width = 68, ;
                Style = 3, ;
                Name = "Label2"

            ADD OBJECT text2 AS textbox WITH ;
                FontName = "Courier New", ;
                Alignment = 3, ;
                Value = 0, ;
                Height = 23, ;
                InputMask = "999,999.999", ;
                Left = 101, ;
                SelectOnEntry = .T., ;
                Top = 65, ;
                Width = 128, ;
                Name = "Text2"


            ADD OBJECT label3 AS label WITH ;
                AutoSize = .T., ;
                BackStyle = 0, ;
                Caption = "Enter Value:", ;
                Height = 17, ;
                Left = 25, ;
                Top = 99, ;
                Width = 68, ;
                Style = 3, ;
                Name = "Label3"

            ADD OBJECT text3 AS textbox WITH ;
                FontName = "Courier New", ;
                Alignment = 3, ;
                Value = 0, ;
                Height = 23, ;
                InputMask = "999,999.999", ;
                Left = 101, ;
                SelectOnEntry = .T., ;
                Top = 96, ;
                Width = 128, ;
                Name = "Text3"

            ADD OBJECT label4 AS label WITH ;
                AutoSize = .T., ;
                BackStyle = 0, ;
                Caption = "Enter Value:", ;
                Height = 17, ;
                Left = 26, ;
                Top = 131, ;
                Width = 68, ;
                Style = 3, ;
                Name = "Label4"

            ADD OBJECT text4 AS textbox WITH ;
                FontName = "Courier New", ;
                Alignment = 3, ;
                Value = 0, ;
                Height = 23, ;
                InputMask = "999,999.999", ;
                Left = 102, ;
                SelectOnEntry = .T., ;
                Top = 128, ;
                Width = 128, ;
                Name = "Text4"

            ADD OBJECT label5 AS label WITH ;
                AutoSize = .T., ;
                WordWrap = .T., ;
                Caption = "Here the additional OK Button closes the entry form", ;
                Height = 32, ;
                Left = 12, ;
                Top = 168, ;
                Width = 204, ;
                Name = "Label5"

            PROCEDURE Destroy
                ** Kill the Keyboard
                Thisform.okeyboard = .NULL.
            ENDPROC

            PROCEDURE Init
                 *
                * THISFORM.oKeyboard = NEWOBJECT("tlbNumKeyboard1")     &&uncomment to see another keybord....
                ** choose the one you like best
                THISFORM.oKeyboard = NEWOBJECT("tlbNumKeyboard2")
                ** see also Form.Destroy for killig it

                WITH THISFORM.oKeyboard
                    .LEFT = THISFORM.LEFT + THISFORM.WIDTH && position to the right of form
                    .TOP = (_SCREEN.HEIGHT - .HEIGHT) /2
                    .VISIBLE = .T.
                ENDWITH
            ENDPROC


            PROCEDURE text1.LostFocus
                This.BackColor = RGB(255,255,255)
            ENDPROC


            PROCEDURE text1.GotFocus
                This.BackColor = RGB(255,128,255)
            ENDPROC

            PROCEDURE text2.GotFocus
                This.BackColor = RGB(255,128,255)
            ENDPROC

            PROCEDURE text2.LostFocus
                This.BackColor = RGB(255,255,255)
            ENDPROC

            PROCEDURE text3.GotFocus
                This.BackColor = RGB(255,128,255)
            ENDPROC

            PROCEDURE text3.LostFocus
                This.BackColor = RGB(255,255,255)
            ENDPROC

            PROCEDURE text4.GotFocus
                This.BackColor = RGB(255,128,255)
            ENDPROC

            PROCEDURE text4.LostFocus
                This.BackColor = RGB(255,255,255)
            ENDPROC

            Procedure destroy
            clea events
            endproc

        ENDDEFINE
        *
        *-- EndDefine: asup
        **************************************************
        *
        DEFINE CLASS cmdkeyboard AS commandbutton
            Height = 70
            Width = 70
            FontBold = .T.
            FontName = "Verdana"
            FontSize = 22
            Picture = "img1.jpg"    &&"images\rot02_70x70.jpg"
            Caption = "1"
            PicturePosition = 12
            Alignment = 2
            Name = "cmdkeyboard"

            PROCEDURE Click
                DO CASE
                CASE This.Caption ="C"
                    KEYBOARD "{BACKSPACE}"
                CASE This.Caption ="Space"
                    KEYBOARD " "
                CASE This.Caption ="<"
                    KEYBOARD "{LEFTARROW}"
                CASE This.Caption =">"
                    KEYBOARD "{RIGHTARROW}"
                CASE This.Caption = CHR(0xFC)   && this is the Ansicode of that WingDings symbols, See \Windows\CharMap.exe for those codes
                    KEYBOARD "{ENTER}"
                    ** Want to close the form?
                    _screen.ActiveForm.release()

                CASE This.Caption = CHR(0xD9)
                    KEYBOARD "{UPARROW}"
                CASE This.Caption = CHR(0xDA)
                    KEYBOARD "{DNARROW}"
                CASE This.Caption = "."
                    KEYBOARD SET("POINT")   && for international settings

                OTHERWISE
                    KEYBOARD This.Caption
                ENDCASE
            ENDPROC
        ENDDEFINE
        *
        *-- EndDefine: cmdkeyboard

        *
        DEFINE CLASS cntnumkeyboard1 AS container
            Width = 209
            Height = 278
            BackStyle = 0
            BorderWidth = 0
            Name = "cntnumkeyboard1"

            ADD OBJECT cmdkeyboard1 AS cmdkeyboard WITH ;
                Top = 0, ;
                Left = 0, ;
                Name = "Cmdkeyboard1"

            ADD OBJECT cmdkeyboard2 AS cmdkeyboard WITH ;
                Top = 0, ;
                Left = 69, ;
                Caption = "2", ;
                Name = "Cmdkeyboard2"

            ADD OBJECT cmdkeyboard3 AS cmdkeyboard WITH ;
                Top = 0, ;
                Left = 138, ;
                Caption = "3", ;
                Name = "Cmdkeyboard3"

            ADD OBJECT cmdkeyboard4 AS cmdkeyboard WITH ;
                Top = 69, ;
                Left = 0, ;
                Caption = "4", ;
                Name = "Cmdkeyboard4"

            ADD OBJECT cmdkeyboard5 AS cmdkeyboard WITH ;
                Top = 69, ;
                Left = 69, ;
                Caption = "5", ;
                Name = "Cmdkeyboard5"

            ADD OBJECT cmdkeyboard6 AS cmdkeyboard WITH ;
                Top = 69, ;
                Left = 138, ;
                Caption = "6", ;
                Name = "Cmdkeyboard6"

            ADD OBJECT cmdkeyboard7 AS cmdkeyboard WITH ;
                Top = 138, ;
                Left = 0, ;
                Caption = "7", ;
                Name = "Cmdkeyboard7"

            ADD OBJECT cmdkeyboard8 AS cmdkeyboard WITH ;
                Top = 138, ;
                Left = 69, ;
                Caption = "8", ;
                Name = "Cmdkeyboard8"

            ADD OBJECT cmdkeyboard9 AS cmdkeyboard WITH ;
                Top = 138, ;
                Left = 138, ;
                Caption = "9", ;
                Name = "Cmdkeyboard9"

            ADD OBJECT cmdkeyboard10 AS cmdkeyboard WITH ;
                Top = 207, ;
                Left = 0, ;
                Caption = ".", ;
                Name = "Cmdkeyboard10"

            ADD OBJECT cmdkeyboard11 AS cmdkeyboard WITH ;
                Top = 207, ;
                Left = 69, ;
                Caption = "0", ;
                Name = "Cmdkeyboard11"

            ADD OBJECT cmdkeyboard12 AS cmdkeyboard WITH ;
                Top = 207, ;
                Left = 138, ;
                Caption = "C", ;
                Name = "Cmdkeyboard12"
        ENDDEFINE
        *
        *-- EndDefine: cntnumkeyboard1

        *
        DEFINE CLASS cntnumkeyboard2 AS cntnumkeyboard1
            Width = 284
            Height = 279
            Name = "cntnumkeyboard2"
            Cmdkeyboard1.Name = "Cmdkeyboard1"
            Cmdkeyboard2.Name = "Cmdkeyboard2"
            Cmdkeyboard3.Name = "Cmdkeyboard3"
            Cmdkeyboard4.Name = "Cmdkeyboard4"
            Cmdkeyboard5.Name = "Cmdkeyboard5"
            Cmdkeyboard6.Name = "Cmdkeyboard6"
            Cmdkeyboard7.Name = "Cmdkeyboard7"
            Cmdkeyboard8.Name = "Cmdkeyboard8"
            Cmdkeyboard9.Name = "Cmdkeyboard9"
            Cmdkeyboard10.Name = "Cmdkeyboard10"
            Cmdkeyboard11.Name = "Cmdkeyboard11"
            Cmdkeyboard12.Name = "Cmdkeyboard12"

            ADD OBJECT cmdkeyboard13 AS cmdkeyboard WITH ;
                Top = 1, ;
                Left = 212, ;
                Height = 70, ;
                Width = 70, ;
                FontName = "Wingdings", ;
                Picture ="img2.jpg", ;
                Caption = "Ù", ;
                Name = "Cmdkeyboard13"

            ADD OBJECT cmdkeyboard14 AS cmdkeyboard WITH ;
                Top = 70, ;
                Left = 212, ;
                Height = 70, ;
                Width = 70, ;
                FontName = "Wingdings", ;
                Picture = "img2.jpg", ;
                Caption = "Ú", ;
                Name = "Cmdkeyboard14"

            ADD OBJECT cmdkeyboard15 AS cmdkeyboard WITH ;
                Top = 139, ;
                Left = 212, ;
                Height = 139, ;
                Width = 70, ;
                FontName = "Wingdings", ;
                FontSize = 34, ;
                Picture = "img2.jpg" , ;
                Caption = "ü", ;
                Name = "Cmdkeyboard15"

        ENDDEFINE
        *
        *-- EndDefine: cntnumkeyboard2
        **************************************************
        *
        DEFINE CLASS tlbnumkeyboard1 AS toolbar
            Caption = "Numeric Input"
            Height = 284
            Left = 0
            Top = 0
            Width = 219
            ControlBox = .F.
            Name = "tlbnumkeyboard1"

            ADD OBJECT cntnumkeyboard1 AS cntnumkeyboard1 WITH ;
                Top = 3, ;
                Left = 5, ;
                Name = "Cntnumkeyboard1", ;
                Cmdkeyboard1.Name = "Cmdkeyboard1", ;
                Cmdkeyboard2.Name = "Cmdkeyboard2", ;
                Cmdkeyboard3.Name = "Cmdkeyboard3", ;
                Cmdkeyboard4.Name = "Cmdkeyboard4", ;
                Cmdkeyboard5.Name = "Cmdkeyboard5", ;
                Cmdkeyboard6.Name = "Cmdkeyboard6", ;
                Cmdkeyboard7.Name = "Cmdkeyboard7", ;
                Cmdkeyboard8.Name = "Cmdkeyboard8", ;
                Cmdkeyboard9.Name = "Cmdkeyboard9", ;
                Cmdkeyboard10.Name = "Cmdkeyboard10", ;
                Cmdkeyboard11.Name = "Cmdkeyboard11", ;
                Cmdkeyboard12.Name = "Cmdkeyboard12"

        ENDDEFINE
        *
        *-- EndDefine: tlbnumkeyboard1
        *
        DEFINE CLASS tlbnumkeyboard2 AS toolbar
            Caption = "Numeric Input"
            Height = 285
            Left = 0
            Top = 0
            Width = 294
            ControlBox = .F.
            Name = "tlbnumkeyboard2"

            ADD OBJECT cntnumkeyboard21 AS cntnumkeyboard2 WITH ;
                Top = 3, ;
                Left = 5, ;
                Name = "Cntnumkeyboard21", ;
                Cmdkeyboard1.Name = "Cmdkeyboard1", ;
                Cmdkeyboard2.Name = "Cmdkeyboard2", ;
                Cmdkeyboard3.Name = "Cmdkeyboard3", ;
                Cmdkeyboard4.Name = "Cmdkeyboard4", ;
                Cmdkeyboard5.Name = "Cmdkeyboard5", ;
                Cmdkeyboard6.Name = "Cmdkeyboard6", ;
                Cmdkeyboard7.Name = "Cmdkeyboard7", ;
                Cmdkeyboard8.Name = "Cmdkeyboard8", ;
                Cmdkeyboard9.Name = "Cmdkeyboard9", ;
                Cmdkeyboard10.Name = "Cmdkeyboard10", ;
                Cmdkeyboard11.Name = "Cmdkeyboard11", ;
                Cmdkeyboard12.Name = "Cmdkeyboard12", ;
                Cmdkeyboard13.Name = "Cmdkeyboard13", ;
                Cmdkeyboard14.Name = "Cmdkeyboard14", ;
                Cmdkeyboard15.Name = "Cmdkeyboard15"

        ENDDEFINE
        *
        *-- EndDefine: tlbnumkeyboard2

*endcode


Working on VFP objects dynamically - partI
Working on VFP objects dynamically - partI

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

To be informed of the latest articles, subscribe:
Comment on this post
C
Muy buena pagina
Reply