Working on VFP objects dynamically - part3

Published on April 22 2017 by Yousfi Benameur


this is a top level form with resizing all inner controls.
Anchoring dont suffisent to do the perfect resizing.this add a class (from Marcia Akins) to resize each object contained on form and preserve some ratio.it needed with large screens.
there is another class adding a shape behind each control at mouseEnter making some shadow color.the shape is destroyed with mouseLeave event.
click on each option in optionGroup control to reach some web images dynamically (avoiding disc) with the pictureVal image control property (all is in memory).

Note: of course can convert the resizing class below to visual custom class and drop it onto any form as embed class.
for converting any prg class to a visual vcx class can use this Tom Rettig utility:
http://fox.wikis.com/wc.dll?Wiki~PrgToVcx
-addded a similar lightbox on form with random color.
[Post 228]

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

*1*

_screen.windowState=1
close data all
*create web urls to link to some web images.

create cursor yhm (yimage c(200))
insert into yhm values("https://lh3.googleusercontent.com/F2wrS38HmZz5hmKl7fWKbgx5xnVmwbCj-8cNbOd3JqnKj2y9kKVwK3N4ncaHr7R4VXrAtzmqwFbA5FM4q1hG6_ClLOoMuhCq=w293-h220")
insert into yhm values("https://lh3.googleusercontent.com/OtT3A1-Z7ljqlnVdFc20gHl_Fp37qmhwu0N_gFYajzS6wQ_0393FFA6bbQ76Dsrq4sG2GWrfqzfujOpFnE1g4v65W6n2rVJb=w293-h220")
insert into yhm values("https://lh3.googleusercontent.com/yvBTsFA9q2Ahxv6QT24CWzYuisyk_G9zAmzDH3Tv5WPKbL9WCyYPgmafl-pnP2Ccz8iLmGHSdrD_FWKIdZFqxHhIo1fwMujG=w293-h220")
insert into yhm values("https://lh3.googleusercontent.com/UA9TO-BnbRXfSLNvfDB--VRR6t9-zYukvIxXqwfs1tBdqO8jK4PKmZ9rwFhZdcsF6X05nq-6tPFF9rPhb59HPbeuJggW677s=w293-h220")
insert into yhm values("https://lh3.googleusercontent.com/eWp1G7UtJLHkgAm4rRWKLCY3uPoa8S9L-UJ6GIrVdLcDld-SZSJc2LHwzJbHLGKNWzajV7OwQVffA9654DmhxMPy2aEeUBBK=w293-h220")
insert into yhm values("https://lh3.googleusercontent.com/YzL0sxgqjh0fPHiXADB_-7Y8d1BvC5AGAN6Qk6W3ytvFJrB0Hfjq2y_2kpxpl5A6BzaK7tLiHjdoClFzmuC9x7INfKSHkiYN=w293-h220")
insert into yhm values("https://lh3.googleusercontent.com/oeVq3QdGMiD44xvfuU80yvnTN0AoJPfMok47bjYHsjOADrNOQC3hCjC6Jd5zSr1CZl3cQvijK1xxk72jOFJYYBi0IYnZYqYo=w293-h220")
insert into yhm values("https://lh3.googleusercontent.com/c5q_4_7dUZ0zbmTF_QtWIvgoCHNxKvguT3SGDBQ3lkl9Z6ZwtOyW3JParpyZbrEjpnQO1jahmwpV9fnA1hlh9tZdb5wBaKzP=w293-h220")
sele yhm
locate

Publi yform
yform=Newobject("asup")
yform.Show
Read Events
retu
*
Define Class asup As Form
Height = 497
Width = 897
ShowWindow = 2
AutoCenter = .T.
Caption = "Rezizer class-dynamic effects on form"
BackColor = Rgb(212,210,208)
Name = "Form1"

Add Object yhelp As Label With ;
Anchor=0,;
AutoSize = .T., ;
FontBold = .T., ;
FontSize = 32, ;
BackStyle = 0, ;
Caption = "?", ;
Height = 54, ;
Left = 855, ;
Top = 2, ;
Width = 20, ;
forecolor=rgb(0,255,0),;
mousepointer=15,;
Name = "yhelp"

Add Object label1 As Label With ;
AutoSize = .T., ;
FontBold = .T., ;
FontSize = 32, ;
BackStyle = 0, ;
Caption = "Hello World", ;
Height = 54, ;
Left = 10, ;
Top = 26, ;
Width = 239, ;
Name = "Label1"

Add Object command1 As CommandButton With ;
Top = 204, ;
Left = 12, ;
Height = 49, ;
Width = 193, ;
Caption = "Command1", ;
Name = "Command1"

Add Object image1 As Image With ;
Picture = "..\..\_____100photos\hammam ouarka g+\sam_3227_resized.jpg", ;
Stretch = 2, ;
Height = 157, ;
Left = 324, ;
Top = 48, ;
Width = 252, ;
Name = "Image1"

Add Object container1 As ycont With ;
Top = 264, ;
Left = 9, ;
Width = 432, ;
Height = 157, ;
Name = "Container1"

Add Object optiongroup1 As OptionGroup With ;
AutoSize = .T., ;
ButtonCount = 5, ;
BackStyle = 0, ;
Value = 1, ;
Height = 27, ;
Left = 264, ;
Top = 2, ;
Width = 323, ;
Name = "Optiongroup1", ;
Option1.Caption = "Option1", ;
Option1.Value = 1, ;
Option1.Height = 17, ;
Option1.Left = 5, ;
Option1.Style = 0, ;
Option1.Top = 5, ;
Option1.Width = 61, ;
Option1.AutoSize = .F., ;
Option1.Name = "Option1", ;
Option2.Caption = "Option2", ;
Option2.Height = 17, ;
Option2.Left = 68, ;
Option2.Style = 0, ;
Option2.Top = 5, ;
Option2.Width = 61, ;
Option2.AutoSize = .F., ;
Option2.Name = "Option2", ;
Option3.Caption = "Option3", ;
Option3.Height = 17, ;
Option3.Left = 131, ;
Option3.Style = 0, ;
Option3.Top = 5, ;
Option3.Width = 61, ;
Option3.AutoSize = .F., ;
Option3.Name = "Option3", ;
Option4.Caption = "Option4", ;
Option4.Height = 17, ;
Option4.Left = 194, ;
Option4.Style = 0, ;
Option4.Top = 5, ;
Option4.Width = 61, ;
Option4.AutoSize = .F., ;
Option4.Name = "Option4", ;
Option5.Caption = "Option5", ;
Option5.Height = 17, ;
Option5.Left = 257, ;
Option5.Style = 0, ;
Option5.Top = 5, ;
Option5.Width = 61, ;
Option5.AutoSize = .F., ;
Option5.Name = "Option5"

Add Object commandgroup1 As CommandGroup With ;
AutoSize = .T., ;
ButtonCount = 4, ;
Value = 1, ;
Height = 124, ;
Left = 216, ;
Top = 120, ;
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", ;
Command3.Top = 63, ;
Command3.Left = 5, ;
Command3.Height = 27, ;
Command3.Width = 84, ;
Command3.Caption = "Command3", ;
Command3.Name = "Command3", ;
Command4.Top = 92, ;
Command4.Left = 5, ;
Command4.Height = 27, ;
Command4.Width = 84, ;
Command4.Caption = "Command4", ;
Command4.Name = "Command4"

Add Object grid1 As Grid With ;
Height = 253, ;
Left = 456, ;
Top = 228, ;
Width = 420, ;
Themes = .F., ;
Name = "Grid1"

Add Object list1 As ListBox With ;
Height = 181, ;
Left = 651, ;
Top = 18, ;
Width = 157, ;
Name = "List1"

Add Object label2 As Label With ;
AutoSize = .T., ;
FontBold = .T., ;
FontSize = 32, ;
BackStyle = 0, ;
Caption = "Hello World", ;
Height = 54, ;
Left = 5, ;
Top = 26, ;
Width = 239, ;
ForeColor = Rgb(0,255,0), ;
Name = "Label2"

Add Object combo1 As ComboBox With ;
Height = 25, ;
Left = 12, ;
Top = 120, ;
Width = 157, ;
Name = "Combo1"

procedure yhelp.click
local m.myvar
text to m.myvar pretext 7 noshow
this is a top level form with resizing all inner controls.
Anchoring dont suffisent to do the perfect resizing.this add a class (for Marcia Akins) to resize each
object contained on form and preserve some ratio.it needed with large screens.
there is another class adding a shape behind each control at mouseEnter making some shadow color.the shape
is destroyed with mouseLeave event.
click on each option in optionGroup control to reach some web images dynamically (avoiding disc) with the
pictureVal image control property (all is in memory).
endtext
messagebox(m.myvar,0+32+4096,"summary help")
endproc

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

With Thisform
If Vartype(.yshape)="O"
	.RemoveObject("yshape")
Endi
.AddObject("yshape","shape")
With .yshape
	.Left=loObject.Left-5
	.Top=loObject.Top-5
	.Width=loObject.Width+10
	.Height=loObject.Height+10
	.BackColor=Rgb(255*Rand(),255*Rand(),255*Rand())
	.ZOrder(1)
	.Name="yshape"
	.Visible=.T.
Endwith
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 Thisform
If Vartype(.yshape)="O"
	.RemoveObject("yshape")
Endi
Endwith
Endproc

Procedure my2
Lparameters nButton, nShift, nXCoord, nYCoord
*!*	*--- aevent create an array laEvents
*!*	Aevents( myArray, 0)
*!*	*--- reference the calling object
*!*	loObject = myArray[1]
sele yhm
try
skip
catch
locate
endtry
if empty(yimage)
locate
endi
thisform.image1.PictureVal=yloadImg(yimage)
sele yhm
try
skip
catch
locate
endtry
if empty(yimage)
locate
endi
thisform.container1.image1.PictureVal=yloadImg(yimage)
Endproc

Procedure Load
Sele  company From Home(1)+"samples\data\customer" Into Cursor ycurs
Sele * From Home(1)+"samples\data\customer" Into Cursor zcurs
Endproc

Procedure Init
With Thisform
.SetAll("mousepointer",15,"commandbutton")
For i=1 To .ControlCount
	Bindevent(.Controls(i),"mouseEnter",Thisform,"my")
	Bindevent(.Controls(i),"mouseLeave",Thisform,"my1")
Endfor
endwith

with thisform.optionGroup1
.setall("mousepointer",15,"OptionButton")
for i=1 to .buttoncount
bindevent(.buttons(i),"mousedown",thisform,"my2")

endfor
Endwith

*** Add the resizer
This.Newobject( 'Resizer', 'stdResizer')  
Return DoDefault()
Endproc

Procedure Resize
This.Resizer.AdjustControls()
Endproc

Procedure Destroy
Clea Events
Endproc

Procedure optiongroup1.Init
This.SetAll("autosize",.T.,"OptionButton")
This.SetAll("fontsize",8,"OptionButton")
This.SetAll("backstyle",0,"OptionButton")
Endproc

Procedure grid1.Init
With This
.RecordSource="zcurs"
.RecordSourceType=1
.DeleteMark=.F.
.GridLines=0
.FontBold=.T.
For i=1 To .ColumnCount
	.Columns(i).header1.BackColor=0
	.Columns(i).header1.ForeColor=255
	.Columns(i).header1.FontSize=12
Endfor
.SetAll("DynamicBackColor", "IIF(MOD(RECNO( ), 2)=0, RGB(145,55,105)  , RGB(100,175,40))", "Column")
Sele zcurs
Locate
.Refresh
Endwith
Endproc

Procedure list1.Init
With This
.RowSource="ycurs"
.RowSourceType=6
Sele ycurs
Locate
.ListIndex=1
.SelectedItemBackColor=Rgb(70,60,50)
.SelectedItemForeColor=Rgb(10,191,160)
.SpecialEffect=1
.FontSize=8
.ItemBackColor=Rgb(40,40,40)
.ItemForeColor=Rgb(255,204,153)
.BorderColor=Rgb(235,132,0)
.ItemTips=.T.
.MousePointer=15
Endwith
Endproc

Procedure combo1.Init
With This
For i=1 To 10
	.AddItem("Item"+Trans(i))
Endfor
.ListIndex=1
.Style=2
Endwith
Endproc
Enddefine
*
*-- EndDefine: asup

*Author: Marcia Atkins
*-- Time Stamp:   01/04/05 06:00:13 PM
*-- Self maximizing form for sovereign applications
* if need this to work on wide screen monitors, you will have to tweak the code for the different aspect ratio:
Define Class stdResizer As Custom
Height = 23
Width = 16
Name = "stdresizer"

Procedure saveoriginaldimensions
*-- Called from the resizer's init...saves the original dimension of all for objects...must be modified so it can be called explicitly when delayed instantiation is used
*Procedure saveoriginaldimensions
Lparameters tocontrol
Local loPage, loControl, loColumn, lnCol

*** If the object does not have an AddProperty method,
*** we can't add the properties to save the original dimension.
*** So bail out
If Not Pemstatus( tocontrol, 'AddProperty', 5 )
Return
Endif
With tocontrol
*** Go ahead and add the properties to hold the object's original dimensions
If Pemstatus( tocontrol, 'Width', 5 )
	If Not Pemstatus( tocontrol, 'nOriginalWidth', 5 )
		.AddProperty( 'nOriginalWidth', .Width )
	Endif
Endif
If Pemstatus( tocontrol, 'Height', 5 )
	If Not Pemstatus( tocontrol, 'nOriginalHeight', 5 )
		.AddProperty( 'nOriginalHeight', .Height )
	Endif
Endif
If Pemstatus( tocontrol, 'Top', 5 )
	If Not Pemstatus( tocontrol, 'nOriginalTop', 5 )
		.AddProperty( 'nOriginalTop', .Top )
	Endif
Endif
If Pemstatus( tocontrol, 'Left', 5 )
	If Not Pemstatus( tocontrol, 'nOriginalLeft', 5 )
		.AddProperty( 'nOriginalLeft', .Left )
	Endif
Endif
If Pemstatus( tocontrol, 'Fontsize', 5 )
	If Not Pemstatus( tocontrol, 'nOriginalFontSize', 5 )
		.AddProperty( 'nOriginalFontSize', .FontSize )
	Endif
Endif
*** Now see if we have to drill down. Also, take care of special
*** case like grids where we have to save RowHeight, HeaderHeight, etc
*** And combos where we need to save ColumnWidths
Do Case
Case Upper( .BaseClass ) = 'PAGEFRAME'
	For Each loPage In .Pages
		This.saveoriginaldimensions( loPage )
	Endfor

Case Inlist( Upper( .BaseClass ), 'PAGE', 'CONTAINER' )
	For Each loControl In .Controls
		This.saveoriginaldimensions( loControl )
	Endfor

Case Upper( .BaseClass ) = 'GRID'
	If Not Pemstatus( tocontrol, 'nOriginalRowHeight', 5 )
		.AddProperty( 'nOriginalRowHeight',    .RowHeight )
	Endif
	If Not Pemstatus( tocontrol, 'nOriginalHeaderHeight', 5 )
		.AddProperty( 'nOriginalHeaderHeight', .HeaderHeight )
	Endif
	If Not Pemstatus( tocontrol, 'nOriginalColumnWidths[ 1 ]', 5 )
		.AddProperty( 'nOriginalColumnWidths[ 1 ]' )
	Endif
****
*** Changed By.: Marcia G. Akins on 15 September 2006
*** Reason.....: Causes a crashing error if grid has no columns
****
	If .ColumnCount > 0
		Dimension .nOriginalColumnWidths[ .ColumnCount ]
		For lnCol = 1 To .ColumnCount
			.nOriginalColumnWidths[lnCol] = .Columns[ lnCol ].Width
		Endfor
	Endif
Case Inlist( Upper( .BaseClass ), 'COMBOBOX', 'LISTBOX' )
	If Not Pemstatus( tocontrol, 'nOriginalColumnWidths', 5 )
		.AddProperty( 'nOriginalColumnWidths', .ColumnWidths )
	Endif

Case Inlist( Upper( .BaseClass ), 'COMMANDGROUP', 'OPTIONGROUP' )
	Local   lnButton
	For lnButton = 1 To .ButtonCount
		This.saveoriginaldimensions( .Buttons[ lnButton ] )
	Endfor
Otherwise
*** There is no otherwise...I think we got all cases
Endcase
Endwith
*Endproc
Endproc

Procedure resizecontrols
*-- Called from the adjustControls method, it resizes and repositions each control it is passed and drills down when necessary
*Procedure resizecontrols
Lparameters tocontrol, tnWidthRatio, tnHeightRatio
Local Array lnColumnWidths[ 1 ]
Local   loPage, loControl, loColumn, lnCol

With tocontrol
If Pemstatus( tocontrol, 'Width', 5 )
	If Pemstatus( tocontrol, 'nOriginalWidth', 5 )
		.Width = .nOriginalWidth * tnWidthRatio
	Endif
Endif
If Pemstatus( tocontrol, 'Height', 5 )
	If Pemstatus( tocontrol, 'nOriginalHeight', 5 )
		.Height = .nOriginalHeight * tnHeightRatio
	Endif
Endif
If Pemstatus( tocontrol, 'Top', 5 )
	If Pemstatus( tocontrol, 'nOriginalTop', 5 )
		.Top = .nOriginalTop * tnHeightRatio
	Endif
Endif
If Pemstatus( tocontrol, 'Left', 5 )
	If Pemstatus( tocontrol, 'nOriginalLeft', 5 )
		.Left = .nOriginalLeft * tnWidthRatio
	Endif
Endif
*** Now resize the font of the control
*** But only if it is not a grid or an edit box. For these controls,
*** we want to see more info, not a bigger font
If Not Inlist( Upper( .BaseClass ), 'GRID', 'EDITBOX', 'LISTBOX' )
	If Pemstatus( tocontrol, 'Fontsize', 5 )
		If Pemstatus( tocontrol, 'nOriginalFontSize', 5 )
			.FontSize = Iif( Int( .nOriginalFontSize * tnHeightRatio ) < 1, 1, ;
				INT( .nOriginalFontSize * tnHeightRatio )   )
		Endif
	Endif
Endif

Do Case
Case Upper( .BaseClass ) = 'PAGEFRAME'
	For Each loPage In .Pages
		This.resizecontrols( loPage, tnWidthRatio, tnHeightRatio )
	Endfor

Case Inlist( Upper( .BaseClass ), 'PAGE', 'CONTAINER' )
	For Each loControl In .Controls
		This.resizecontrols( loControl, tnWidthRatio, tnHeightRatio )
	Endfor

Case Inlist( Upper( .BaseClass ), 'COMBOBOX', 'LISTBOX' )
	Local   lnCol, lnStart,   lnEnd, lnLen, lcColumnWidths
	If .ColumnCount < 2
		.ColumnWidths = Alltrim( Str( .Width ) )
	Else
		lcColumnWidths = ''
		lnStart        = 1
		For lnCol = 1 To .ColumnCount - 1
			lnEnd = At( ',', .nOriginalColumnWidths, lnCol )
			lnLen = lnEnd - lnStart
			lcColumnWidths = lcColumnWidths + ;
				IIF( Empty( lcColumnWidths ), '', ',' ) + ;
				ALLTRIM( Str( Val( Substr( .nOriginalColumnWidths, lnStart, lnLen ) ) * tnWidthRatio ) )
			lnStart = lnEnd + 1
		Endfor
		lnLen = Len( .nOriginalColumnWidths ) - lnStart + 1
		lcColumnWidths = lcColumnWidths   + ',' + ;
			ALLTRIM( Str( Val( Substr( .nOriginalColumnWidths, lnStart, lnLen ) ) * tnWidthRatio ) )
		.ColumnWidths = lcColumnWidths
	Endif

Case Inlist( Upper( .BaseClass ), 'COMMANDGROUP', 'OPTIONGROUP' )
	Local lnButton
	For lnButton = 1 To .ButtonCount
		This.resizecontrols( .Buttons[ lnButton ], tnWidthRatio, tnHeightRatio )
	Endfor

Otherwise
*** There is no otherwise...I think we got all cases
Endcase
Endwith
* Endproc
Endproc

Procedure AdjustControls
*-- Called from the form's Resize even, it loops through the form's controls collection and passes a reference to each object to the class's ResizeControls method so it can be resized and/or drilled down into
*Procedure adjustcontrols
Lparameter tocontrol
Local llLockScreen, loControl, loParent, lnWidthRatio, lnHeightRatio

If Vartype( tocontrol ) # 'O' And Not Isnull( tocontrol )
loParent = This.Parent
Else
loParent = tocontrol
Endif

*** Bail out if the any of the required properties are not found in the
*** parent container
If Not Pemstatus( Thisform, 'nOriginalWidth', 5 )
Return
Endif
If Not Pemstatus( Thisform, 'nOriginalHeight', 5 )
Return
Endif

With Thisform
lnWidthRatio  = .Width  / .nOriginalWidth
lnHeightRatio = .Height / .nOriginalHeight

*** Save current status of LockScreen
llLockScreen = .LockScreen
.LockScreen = .T.

For Each loControl In loParent.Controls
	This.resizecontrols( loControl, lnWidthRatio, lnHeightRatio )
Endfor

.LockScreen = llLockScreen
Endwith
* Endproc
Endproc

Procedure Init
* Procedure Init
Local loContainer, loControl
loContainer = This.Parent
With loContainer
*** If the parent continer doesn't have the nOriginalHeight and nOriginalWidth properties
*** then add them and save the form dimensions
If Not Pemstatus( loContainer, 'nOriginalHeight', 5 )
	.AddProperty( 'nOriginalHeight', .Height )
Endif
If Not Pemstatus( loContainer, 'nOriginalWidth', 5 )
	.AddProperty( 'nOriginalWidth', .Width )
Endif

*** Set a minimun Width and Height to avoid errors later if not
*** already set
If .MinWidth = -1
	.MinWidth  = .Width / 2
Endif
If .MinHeight = -1
	.MinHeight = .Height / 2
Endif

*** Now save the relevant visual properties (height, width, columnwidths, etc)
*** of all the controls on the parent container
For Each loControl In .Controls
	This.saveoriginaldimensions( loControl )
Endfor
Endwith
*  Endproc
Endproc

Enddefine
*-- EndDefine: stdresizer

Define Class ycont As Container
Top = 264
Left = 9
Width = 432
Height = 157
Name = "Container1"

Add Object edit1 As EditBox With ;
Height = 133, ;
Left = 12, ;
Top = 12, ;
Width = 205, ;
Name = "Edit1"

Add Object command1 As CommandButton With ;
Top = 4, ;
Left = 244, ;
Height = 37, ;
Width = 145, ;
Caption = "Command1", ;
Name = "Command1"

Add Object image1 As Image With ;
Picture = "..\..\_____100photos\tiout g+\sam_3059_resized.jpg", ;
Stretch = 2, ;
Height = 97, ;
Left = 220, ;
Top = 48, ;
Width = 205, ;
Name = "Image1"

Procedure edit1.Init
TEXT to this.value noshow
Lorem ipsum dolor sit amet, consectetur adipiscing elit. Proin vel risus eget lorem feugiat
fermentum nec a turpis. Phasellus purus sem, mollis ac posuere eget, ornare vel orci. Sed ac rutrum
nulla. Aenean ultrices eget lectus eu efficitur. In hac habitasse platea dictumst. Nulla in iaculis nisi.
Nullam et pulvinar tellus. Donec arcu dui, efficitur a odio non, porta congue dolor. Aenean viverra
auctor sagittis. Integer lobortis dignissim auctor. Proin et volutpat massa.
ENDTEXT
Endproc

Procedure Init
This.SetAll("mousepointer",15,"commandbutton")
Endproc

Enddefine
*
*-- EndDefine: ycont

function yloadImg
lparameters lcURl
	Local loRequest
	m.loRequest = Createobject('MsXml2.XmlHttp')
	m.loRequest.Open("GET",lcUrl,.F.)
	m.loRequest.Send()
	return(m.loRequest.ResponseBody	)
	m.loRequest=Null
endfunc

Working on VFP objects dynamically - part3

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


I struggled in previous posts to make the form titlebar traversable by adding object as commndbuttons, colors,..
and other stuffs.this was difficult because there is no vfp way actually to work inside the system titlebar.
i subclassed successfully this titlebar by a container...the only way to work with transparency in a container
is to erase one specific color with setLayeredWindow API but applied to all the form.

this is another singular way to do that but with 2 forms.
form is a vfp object having a real windows handle HWND and then can be manipulated with transparency.
A top level form (alwaysonTop) desserves this goal.
A normal top level form (alwaysOnTop) works as a normal form.
the 2 forms are synchronized with code (in particular, form moved event) to work as well as one form.
the first form (titlebar) have transparency variable manually.a value 200 to 210 is available for view.
the transparency is variable form 160-255(opaque).
i added 3 methods to make gradients in a bitmap covering the titlebar.
the colors can be choosed randomly.can be also form .backcolor property.
the titlebar height is variable form 33-66 pixels.
can insert any object...i designed some menus for demo.
notes:
-click to titlebar form to give the focusfor showing tooltips.
*re click  rounded shapes buttons to refresh the titlebar gradients randomly
*once setting background color , image becomes invisible-set a picture (second shape) before running left menu (make image visible).
-the code downloads automatically 15 images.run this once and change ydownl=.f.

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

      


*2* a singular form titlebar---version2
*created on 23 of april 2017 -- updated on 25 of april 2017 (added a lightbox)
*remember that transparency on a vfp form can be applied only in 2 cases
*    - on top level form (showWindow=2)
*    - a form with (showWindow=0,1 and mandatory  desktop=.t.)
*put the gdiplusX library: system.app in source folder to work with lightbox.

Publ m.yrep
m.yrep=Addbs(Justpath(Sys(16,1)))
Set Defa To (yrep)

Local ydownl
m.ydownl=.t.   &&done 1 once and change ydownl=.f. here to dont re download each time

If m.ydownl=.T.
*download some  images from my blog (used by this code)-verify that all 15 imags are downloaded as well.
*can comment these lines after downloading images to run the code
*******begin downloads************
Declare Integer URLDownloadToFile In urlmon.Dll Integer pCaller, String szURL, String szFileName, Integer dwReserved, Integer lpfnCB
Declare Integer DeleteUrlCacheEntry In wininet String lpszUrlName

Local lcUrl,lcDownloadLoc
For i=1 To 15
Do Case
Case i=1
	lcUrl="http://img.over-blog-kiwi.com/300x225-ct/1/43/54/07/20170423/ob_dc2c0d_adobe-pdf-reader.png"
	lcDownloadLoc="adobe_pdf_reader.png"
Case i=2
	lcUrl="http://img.over-blog-kiwi.com/300x225-ct/1/43/54/07/20170423/ob_5320f1_bambou.jpg"
	lcDownloadLoc="bambou.jpg"
Case i=3
	lcUrl="http://img.over-blog-kiwi.com/300x225-ct/1/43/54/07/20170423/ob_f4c5ca_bluetab.jpg"
	lcDownloadLoc="bluetab.jpg"
Case i=4
	lcUrl="http://img.over-blog-kiwi.com/300x225-ct/1/43/54/07/20170423/ob_c74bf1_button-10.png"
	lcDownloadLoc="button_10.png"
Case i=5
	lcUrl="http://img.over-blog-kiwi.com/200x150-ct/1/43/54/07/20170423/ob_a927cd_fonds.jpg"
	lcDownloadLoc="fonds.jpg"
Case i=6
	lcUrl="http://img.over-blog-kiwi.com/200x150-ct/1/43/54/07/20170423/ob_a8e884_fonds-wrapper.jpg"
	lcDownloadLoc="fonds_wrapper.jpg"
Case i=7
	lcUrl="http://img.over-blog-kiwi.com/200x150-ct/1/43/54/07/20170423/ob_c8fe9e_texture.jpg"
	lcDownloadLoc="texture.jpg"
Case i=8
	lcUrl="http://img.over-blog-kiwi.com/200x150-ct/1/43/54/07/20170423/ob_4210e9_texture1.png"
	lcDownloadLoc="texture1.png"
Case i=9
	lcUrl="http://img.over-blog-kiwi.com/200x150-ct/1/43/54/07/20170423/ob_58df6d_texture2.jpg"
	lcDownloadLoc="texture2.jpg"
Case i=10
	lcUrl="http://img.over-blog-kiwi.com/200x150-ct/1/43/54/07/20170423/ob_caa906_texture3.JPG"
	lcDownloadLoc="texture3.jpg"
Case i=11
	lcUrl="http://img.over-blog-kiwi.com/1/43/54/07/20170425/ob_d8492c_cap2.JPG"
	lcDownloadLoc="cap2.jpg"
Case i=12
	lcUrl="http://img.over-blog-kiwi.com/1/43/54/07/20170425/ob_7d1959_cap3.JPG"
	lcDownloadLoc="cap3.jpg"
Case i=13
	lcUrl="http://img.over-blog-kiwi.com/1/43/54/07/20170425/ob_f5c9d6_cap8.JPG"
	lcDownloadLoc="cap8.jpg"
Case i=14
	lcUrl="http://img.over-blog-kiwi.com/1/43/54/07/20170425/ob_60f4b1_cap9.JPG"
	lcDownloadLoc="cap9.jpg"
Case i=15
	lcUrl="http://img.over-blog-kiwi.com/1/43/54/07/20170425/ob_3d8af8_cap7.JPG"
	lcDownloadLoc="cap7.jpg"


Endcase
lnResult = DeleteUrlCacheEntry(lcUrl)
lnResult = URLDownloadToFile(0, lcUrl, lcDownloadLoc , 0,0)
If lnResult = 0
	Wait Window "Download "+lcDownloadLoc +"  Complete" Nowait
*Else
*!*  Messagebox("Download fails")
Endi
Inke(1)
Endfor
**********end downloads****************
Endi

_Screen.WindowState=1
Publi yform
yform=Newobject("yaerot")
yform.Show
Read Events
Retu
*
Define Class yaerot As Form
BorderStyle = 0
Top = 55
Left = 35
Height = 473
Width = 863
ShowWindow = 2
Caption = ""
AlwaysOnTop = .T.
BackColor = Rgb(212,210,208)
xheight_ = 0
Name = "yaerot"

Add Object command1 As CommandButton With ;
Top = 99, ;
Left = 36, ;
Height = 85, ;
Width = 181, ;
FontBold = .T., ;
FontSize = 18, ;
Picture = Home(1)+"graphics\icons\misc\face05.ico", ;
Caption = "Command1", ;
PicturePosition = 2, ;
BackColor = Rgb(128,255,0), ;
Name = "Command1"

Add Object text1 As TextBox With ;
FontBold = .T., ;
Value = "Hello World !", ;
Height = 36, ;
Left = 588, ;
Top = 432, ;
Width = 133, ;
Name = "Text1"

Add Object image1 As Image With ;
Picture = "fonds.jpg", ;
Stretch = 2, ;
Height = 96, ;
Left = 24, ;
Top = 1, ;
Width = 120, ;
Name = "Image1"

Add Object grid1 As Grid With ;
Height = 253, ;
Left = 24, ;
Top = 197, ;
Width = 445, ;
Name = "Grid1"

Add Object olecontrol1 As OleControl With ;
oleclass="shell.explorer.2", ;
Top = 84, ;
Left = 480, ;
Height = 337, ;
Width = 349, ;
Name = "Olecontrol1"

Add Object timer1 As Timer With ;
Top = 72, ;
Left = 804, ;
Height = 23, ;
Width = 23, ;
Enabled = .F., ;
Interval = 10000, ;
Name = "Timer1"

Add Object label1 As Label With ;
AutoSize = .T., ;
FontBold = .T., ;
FontSize = 28, ;
Anchor = 768, ;
BackStyle = 0, ;
Caption = "?", ;
Height = 47, ;
Left = 820, ;
MousePointer = 15, ;
Top = 9, ;
Width = 25, ;
ForeColor = Rgb(0,255,0), ;
Name = "Label1"

Add Object olecontrol2 As OleControl With ;
Oleclass="MSComCtl2.MonthView.2", ;
Top = 12, ;
Left = 252, ;
Height = 169, ;
Width = 205, ;
Name = "Olecontrol2"

Add Object label2 As Label With ;
AutoSize = .T., ;
FontBold = .T., ;
FontName = "Segoe Script", ;
FontSize = 32, ;
BackStyle = 0, ;
Caption = "Hello World", ;
Height = 74, ;
Left = 532, ;
Top = 11, ;
Width = 280, ;
ForeColor = Rgb(0,255,0), ;
Name = "Label2"

Add Object label3 As Label With ;
AutoSize = .T., ;
FontBold = .T., ;
FontName = "Segoe Script", ;
FontSize = 32, ;
BackStyle = 0, ;
Caption = "Hello World", ;
Height = 74, ;
Left = 526, ;
Top = 11, ;
Width = 280, ;
ForeColor = Rgb(255,128,0), ;
Name = "Label3"

Procedure ybuild
Lparameters ximage
Local m.myvar
TEXT to m.myvar textmerge noshow
<!DOCTYPE html>
<html>
  <head>
	<meta charset="utf-8">
	<meta http-equiv="X-UA-Compatible" content="IE=edge,chrome=1">
	<meta name="viewport" content="width=device-width">
	<title>Three.js basic cube example</title>
	<style>
	  html,body {
		margin: 0;
	  }

	  body {
		overflow: hidden;
	  }
	</style>
  </head>
  <body oncontextmenu="return false;" >
  <script src="https://mdn.github.io/learning-area/javascript/apis/drawing-graphics/threejs-cube/three.min.js"></script>
  <script >
var scene = new THREE.Scene();
var camera = new THREE.PerspectiveCamera(75, window.innerWidth / window.innerHeight, 0.1, 1000);
camera.position.z = 5;
var renderer = new THREE.WebGLRenderer();
renderer.setSize(window.innerWidth, window.innerHeight);
document.body.appendChild(renderer.domElement);
var cube;
var loader = new THREE.TextureLoader();
loader.load( '<<allt(ximage)>>', function (texture) {
	texture.wrapS = THREE.RepeatWrapping;
	texture.wrapT = THREE.RepeatWrapping;
	texture.repeat.set(2, 2);
	var geometry = new THREE.BoxGeometry(2.4,2.4,2.4);
	var material = new THREE.MeshLambertMaterial( { map: texture, shading: THREE.FlatShading } );
	cube = new THREE.Mesh(geometry, material);
	scene.add(cube);
	draw();
});

var light = new THREE.AmbientLight('rgb(255,255,255)'); // soft white light
scene.add(light);
var spotLight = new THREE.SpotLight('rgb(255,255,255)');
spotLight.position.set( 100, 1000, 1000 );
spotLight.castShadow = true;
scene.add(spotLight);
function draw() {
  cube.rotation.x += 0.01;
  cube.rotation.y += 0.01;
  renderer.render(scene, camera);
	requestAnimationFrame(draw);
}
  </script>
  </body>
</html>
ENDTEXT
Set Safe Off
Local m.lcdest
m.lcdest=m.yrep+"ytemp.html"
Strtofile(m.myvar,m.lcdest)
Thisform.olecontrol1.Navigate(m.lcdest)
Endproc

Procedure Moved
Try
If Thisform.WindowState=0
	yform1.WindowState=0
	This.Resize
Endi
If Thisform.WindowState=1
	yform1.WindowState=1
Endi
Catch
Endtry
Endproc

Procedure MouseDown
Lparameters nButton, nShift, nXCoord, nYCoord
lnHandle = Thisform.HWnd
param1 = 274
param2 = 0xF012
bb=ReleaseCapture()
bb=SendMessage(lnHandle, param1, param2,0)
Thisform.Resize
Endproc

Procedure Resize
With Thisform
Try
	.Left=yform1.Left
	.Top=yform1.Top+yform1.Height
	.Width=yform1.Width
Catch
Endtry
Endwith
Endproc


Procedure Init

This.TitleBar=0
Create Cursor zcurs  (ximage c(100))
Insert Into zcurs Values ("texture.jpg")
Insert Into zcurs Values ("texture1.png")
Insert Into zcurs Values ("texture2.jpg")
Insert Into zcurs Values ("texture3.jpg")
Sele zcurs
Locate
Thisform.ybuild(Allt(ximage))
Thisform.timer1.Enabled=.T.

Sele * From Home(1)+"samples\data\customer" Into Cursor ycurs

With This.grid1
.RecordSource=""
.RecordSource="ycurs"
.RecordSourceType=1
.DeleteMark=.F.
.GridLines=0
.FontBold=.T.
.SetAll("DynamicBackColor", "IIF(MOD(RECNO( ), 2)=0, RGB(145,55,105)  , RGB(100,255,40))", "Column")
Sele ycurs
Locate
.Refresh
Endwith

Publi yform1
yform1=Newobject("yaerot0")
yform1.Show

Thisform.Resize()
Endproc

Procedure olecontrol1.Init
This.silent=.T.
Endproc

Procedure timer1.Timer
Sele zcurs
Try
Skip
Catch
Locate
Endtry
If Empty(ximage)
Locate
Endi
Thisform.ybuild(ximage)
Endproc

Procedure label1.Click
Local m.myvar
TEXT to m.myvar pretext 7  noshow
I struggled in previous posts to make the form titlebar traversable by adding object as commndbuttons, colors,..
and other stuffs.this was difficult because there is no vfp way actually to work inside the system titlebar.
i subclassed successfully this titlebar by a container...the only way to work with transparency in a container
is to erase one specific color with setLayeredWindow API but applied to all the form.
the 10 images demo download can be used 1 once(and change ydownl=.f. in code)

this is another singular way to do that but with 2 forms.
form is a vfp object having a real windows handle HWND and then can be manipulated with transparency.
A top level form (alwaysonTop) desserves this goal.
A normal top level form (alwaysOnTop) works as a normal form.
the 2 forms are synchronized with code (in particular, form moved event) to work as well as one form.
the first form (titlebar) have transparency variable manually.a value 200 to 210 is available for view.
the transparency is variable form 160-255(opaque).
i added 3 methods to make gradients in a bitmap covering the titlebar.
the colors can be choosed randomly.can be also form .backcolor property.
the titlebar height is variable form 33-66 pixels.
can insert any object...i designed some menus for demo.
the titlebar shape6 offers a similar lightbox with a random color on the form (yform).can choose a fixed balcky color as
rgb(28,28,28).click on form empty area to restore.Note the image created(destroyed) cannot be on top of activeX(always
topmost)

ENDTEXT
*Messagebox(m.myvar,0+32+4096,"Summary help")
Local oshell
oshell = Createobject('WScript.Shell')
oshell.Popup(m.myvar,0, 'Summary help', 0+32+4096)  &&4,16,48,64...
oshell=Null
Endproc

Procedure olecontrol2.Init
With This
.BackColor=4227327
.ForeColor=16711680
.appearance=0
.BorderStyle=0
.monthBackcolor=Rgb(225,238,200)
.titleBackcolor=4259584
Endwith
Endproc


Procedure Destroy
Try   &&release titlebar if releasing yform from taskbar
yform1.Release
Catch
Endtry
Clea Events
Endproc
Enddefine
*
*-- EndDefine: yaerot


Define Class yaerot0 As Form
BorderStyle = 1   &&0,1
Top = 189
Left = 79
Height = 66
Width = 863
ShowWindow = 2
ShowInTaskbar = .F.
ShowTips = .T.
Picture = ""
Caption = "Form1"
AlwaysOnTop = .T.
BackColor = Rgb(128,0,64)
xleft = .F.
xtop = .F.
xwidth = .F.
xheight = .F.
Name = "yaerot0"

Add Object image1 As Image With ;
Anchor = 15, ;
Picture = "bluetab.jpg", ;
Stretch = 2, ;
BorderStyle = 1, ;
Height = 600, ;
Left = 0, ;
Top = 0, ;
Width = 600, ;
Name = "Image1"

Add Object command1 As CommandButton With ;
Top = 7, ;
Left = 837, ;
Height = 20, ;
Width = 20, ;
FontBold = .T., ;
FontSize = 12, ;
Anchor = 768, ;
Caption = "X", ;
MousePointer = 15, ;
SpecialEffect = 2, ;
ForeColor = Rgb(255,0,0), ;
BackColor = Rgb(128,255,0), ;
Name = "Command1"

Add Object spinner1 As Spinner With ;
Anchor = 768, ;
Height = 25, ;
KeyboardHighValue = 255, ;
KeyboardLowValue = 150, ;
Left = 715, ;
SpinnerHighValue = 255.00, ;
SpinnerLowValue = 160.00, ;
ToolTipText = "Transparency 150-255", ;
Top = 5, ;
Width = 61, ;
Value = 205, ;
Name = "Spinner1"

Add Object shape1 As Shape With ;
Top = 11, ;
Left = 618, ;
Height = 13, ;
Width = 13, ;
Anchor = 768, ;
Curvature = 99, ;
MousePointer = 15, ;
ToolTipText = "Background", ;
BackColor = Rgb(0,255,0), ;
Name = "Shape1"

Add Object shape2 As Shape With ;
Top = 11, ;
Left = 600, ;
Height = 13, ;
Width = 13, ;
Anchor = 768, ;
Curvature = 99, ;
MousePointer = 15, ;
ToolTipText = "Backcolor", ;
BackColor = Rgb(255,0,0), ;
Name = "Shape2"

Add Object command2 As CommandButton With ;
Top = 7, ;
Left = 791, ;
Height = 20, ;
Width = 20, ;
FontBold = .T., ;
FontSize = 12, ;
Anchor = 768, ;
Caption = "-", ;
MousePointer = 15, ;
SpecialEffect = 2, ;
ForeColor = Rgb(255,0,0), ;
BackColor = Rgb(128,255,0), ;
Name = "Command2"

Add Object image2 As Image With ;
Anchor = 768, ;
Picture = "button_10.png", ;
Stretch = 2, ;
Height = 25, ;
Left = 101, ;
MousePointer = 15, ;
Top = 12, ;
Width = 109, ;
ToolTipText = "Contextuel menu", ;
Name = "Image2"

Add Object command3 As CommandButton With ;
Top = 7, ;
Left = 814, ;
Height = 20, ;
Width = 20, ;
FontBold = .T., ;
FontName = "Webdings", ;
FontSize = 9, ;
Anchor = 768, ;
Caption = "1", ;
MousePointer = 15, ;
SpecialEffect = 2, ;
ForeColor = Rgb(255,0,0), ;
BackColor = Rgb(128,255,0), ;
Name = "Command3"

Add Object image3 As Image With ;
Anchor = 768, ;
Picture = "adobe_pdf_reader.png", ;
Stretch = 2, ;
Height = 33, ;
Left =5, ;
MousePointer = 15, ;
Top = 10 , ;
Width = 33, ;
ToolTipText = "Menu", ;
Name = "Image3"

Add Object yshape As Shape With ;
Top = 11, ;
Left = 63, ;
Height = 13, ;
Width = 18, ;
Anchor = 768, ;
Curvature = 10, ;
MousePointer = 15, ;
ToolTipText = "Pictures backg", ;
BackColor =0, ;
BorderColor = Rgb(255,255,255), ;
BorderWidth=1,;
Name = "yShape"



Add Object shape3 As Shape With ;
Top = 11, ;
Left = 638, ;
Height = 13, ;
Width = 13, ;
Anchor = 768, ;
Curvature = 99, ;
MousePointer = 15, ;
ToolTipText = "Grad random", ;
BackColor = Rgb(255,255,0), ;
BorderColor = Rgb(255,255,128), ;
Name = "Shape3"

Add Object shape4 As Shape With ;
Top = 11, ;
Left = 663, ;
Height = 13, ;
Width = 13, ;
Anchor = 768, ;
Curvature = 99, ;
MousePointer = 15, ;
ToolTipText = "Grad 2 colors", ;
BackColor = Rgb(0,255,255), ;
Name = "Shape4"

Add Object spinner2 As Spinner With ;
Anchor = 768, ;
Height = 25, ;
KeyboardHighValue = 66, ;
KeyboardLowValue = 33, ;
Left = 527, ;
SpinnerHighValue =  66.00, ;
SpinnerLowValue =  33.00, ;
ToolTipText = "Resize titlebar", ;
Top = 5, ;
Width = 61, ;
Value = 66, ;
Name = "Spinner2"

Add Object shape5 As Shape With ;
Top = 11, ;
Left = 684, ;
Height = 13, ;
Width = 13, ;
Anchor = 768, ;
Curvature = 99, ;
MousePointer = 15, ;
ToolTipText = "Grad random  2 colors", ;
BackColor = Rgb(255,128,64), ;
Name = "Shape5"

Add Object shape6 As Shape With ;
Top = 11, ;
Left = 684+15, ;
Height = 13, ;
Width = 13, ;
Anchor = 768, ;
Curvature = 99, ;
MousePointer = 15, ;
ToolTipText = "Lightbox/1 rand color", ;
BackColor = Rgb(128,0,255), ;
Name = "Shape6"

Procedure ytranspa
Lparameters opa
If !Between(opa,0,255)
opa=255
Endi
#Define GWL_EXSTYLE -20
#Define WS_EX_LAYERED 0x80000
#Define LWA_COLORKEY 1
#Define LWA_ALPHA 2
Local nExStyle, nRgb, nAlpha, nFlags
nExStyle = GetWindowLong(Thisform.HWnd, GWL_EXSTYLE)
nExStyle = Bitor(nExStyle, WS_EX_LAYERED)
= SetWindowLong(Thisform.HWnd, GWL_EXSTYLE, nExStyle)
= SetLayeredWindowAttributes(Thisform.HWnd, Thisform.BackColor, opa,LWA_ALPHA)
Endproc

Procedure rgb2html
Lparameters tnColor
Local loColor
loColor = Createobject("Empty")
AddProperty(loColor, "nR", Bitand(tnColor, 0xFF))
AddProperty(loColor, "nG", Bitand(Bitrshift(tnColor, 8), 0xFF))
AddProperty(loColor, "nB", Bitand(Bitrshift(tnColor, 16), 0xFF))
AddProperty(loColor, "cHTMLcolor", Strtran("#" + ;
TRANSFORM(loColor.nR, "@0") +   ;
TRANSFORM(loColor.nG, "@0") +   ;
TRANSFORM(loColor.nB, "@0"), "0x000000", "" ))
Return loColor.cHTMLcolor
Endproc

Procedure DblClick
Thisform.command3.Click()
Endproc

Procedure Moved
Try
With yform
	.Left=This.Left
	.Top=This.Top+This.Height
	.Width=This.Width
	.WindowState=Thisform.WindowState
Endwith
Catch
Endtry
Endproc

Procedure MouseDown
Lparameters nButton, nShift, nXCoord, nYCoord
This.MousePointer=15
lnHandle = Thisform.HWnd
param1 = 274
param2 = 0xF012
bb=ReleaseCapture()
bb=SendMessage(lnHandle, param1, param2,0)
This.MousePointer=0
Endproc

Procedure KeyPress
Lparameters nKeyCode, nShiftAltCtrl
If nKeyCode=27
Try
	yform.Release
Catch
Endtry
Thisform.Release
Endi
Endproc

Procedure Init
Thisform.TitleBar=0
Set Safe Off
Thisform.ytranspa(210)
Endproc

Procedure Destroy
Clea Events
Endproc

Procedure image1.DblClick
Thisform.command3.Click
Endproc

Procedure image1.Init
With This
.Left=0
.Top=0
.Width=.Parent.Width+5
.Height=.Parent.Height+5
.ZOrder(1)
Endwith
Endproc

Procedure image1.MouseDown
Lparameters nButton, nShift, nXCoord, nYCoord
This.MousePointer=15
lnHandle = Thisform.HWnd
param1 = 274
param2 = 0xF012
bb=ReleaseCapture()
bb=SendMessage(lnHandle, param1, param2,0)
This.MousePointer=0
Endproc

Procedure command1.MouseEnter
Lparameters nButton, nShift, nXCoord, nYCoord
This.BackColor=255
Endproc

Procedure command1.MouseLeave
Lparameters nButton, nShift, nXCoord, nYCoord
This.BackColor=Rgb(0,255,0)
Endproc

Procedure command1.Click
Try
yform.Release
Catch
Endtry
Thisform.Release
Endproc

Procedure spinner1.InteractiveChange
Thisform.ytranspa(This.Value)
Endproc

Procedure yshape.RightClick
This.Click
Endproc

Procedure yshape.Click
Define Popup raccourci SHORTCUT Color N/w*,G+/N*,,,,N/R Relative From Mrow(),Mcol()
Define Bar 1 Of raccourci Prompt "1" ;
PICTURE "cap2.jpg"
Define Bar 2 Of raccourci Prompt "2" ;
PICTURE "cap3.jpg"
Define Bar 3 Of raccourci Prompt "3" ;
PICTURE "cap8.jpg"
Define Bar 4 Of raccourci Prompt "4" ;
PICTURE "cap9.jpg"
Define Bar 5 Of raccourci Prompt "5" ;
PICTURE "cap7.jpg"

On Selection Bar 1 Of raccourci _Screen.ActiveForm.image1.Picture="cap2.jpg"
On Selection Bar 2 Of raccourci _Screen.ActiveForm.image1.Picture="cap3.jpg"
On Selection Bar 3 Of raccourci _Screen.ActiveForm.image1.Picture="cap8.jpg"
On Selection Bar 4 Of raccourci _Screen.ActiveForm.image1.Picture="cap9.jpg"
On Selection Bar 5 Of raccourci _Screen.ActiveForm.image1.Picture="cap7.jpg"

Activate Popup raccourci
Endproc

Procedure shape1.Click
Local m.xpict
m.xpict=Getpict()
If ! Empty(m.xpict)
Thisform.image1.Picture=m.xpict
Thisform.image1.Visible=.T.
Endi
Endproc

Procedure shape2.Click
Local m.xcolor
m.xcolor=Getcolor()
If ! Empty(m.xcolor)
Thisform.BackColor=m.xcolor
Thisform.image1.Visible=.F.
Endi
Endproc

Procedure command2.MouseLeave
Lparameters nButton, nShift, nXCoord, nYCoord
This.BackColor=Rgb(0,255,0)
Endproc

Procedure command2.MouseEnter
Lparameters nButton, nShift, nXCoord, nYCoord
This.BackColor=255
Endproc

Procedure command2.Click
Try
yform.WindowState=1
Catch
Endtry
Thisform.WindowState=1
Endproc

Procedure image2.RightClick
This.Click()
Endproc

Procedure image2.Click
Define Popup raccourci SHORTCUT Relative From Mrow(),Mcol()
Define Bar _Med_slcta Of raccourci Prompt "Sélectionner tout" ;
KEY CTRL+A, "Ctrl+A" ;
PICTRES _Med_slcta ;
MESSAGE "Sélectionne tout le texte ou tous les éléments de la fenêtre active"
Define Bar _Med_paste Of raccourci Prompt "Coller" ;
KEY CTRL+V, "Ctrl+V" ;
PICTRES _Med_paste ;
MESSAGE "Place le contenu du Presse-papiers au point d'insertion"
Define Bar _Med_copy Of raccourci Prompt "Copier" ;
KEY CTRL+c, "Ctrl+C" ;
PICTRES _Med_copy ;
MESSAGE "Copie la sélection et la place dans le Presse-papiers"
Define Bar _Med_cut Of raccourci Prompt "Couper" ;
KEY CTRL+X, "Ctrl+X" ;
PICTRES _Med_cut ;
MESSAGE "Enlève la sélection et la place dans le Presse-papiers"
Define Bar _Med_redo Of raccourci Prompt "Rétablir" ;
KEY CTRL+R, "Ctrl+R" ;
PICTRES _Med_redo
Define Bar _Med_undo Of raccourci Prompt "Annuler" ;
KEY CTRL+Z, "Ctrl+Z" ;
PICTRES _Med_undo ;
MESSAGE "Annule la dernière modification"
Activate Popup raccourci
Endproc

Procedure command3.MouseEnter
Lparameters nButton, nShift, nXCoord, nYCoord
This.BackColor=255
Endproc

Procedure command3.MouseLeave
Lparameters nButton, nShift, nXCoord, nYCoord
This.BackColor=Rgb(0,255,0)
Endproc

Procedure command3.Click
Do Case
Case This.Caption=="1"
Try
	With Thisform
		.xleft=.Left
		.xtop=.Top
		.xwidth=.Width
		.xheight=.Height
		.Left=0
		.Top=0
		.Width=Sysmetric(1)
		.Refresh
	Endwith

	With yform
		.xheight_=.Height
		.Resize()
		.Height=Sysmetric(2)-Thisform.Height
	Endwith
	This.Caption="2"
Catch
Endtry

Case This.Caption=="2"
This.Caption="1"
With Thisform
	.Left=.xleft
	.Top=.xtop
	.Width=.xwidth
Endwith
Try
	With yform
		.Resize()
		.Height=.xheight_
	Endwith
Catch
Endtry

Endcase
Endproc

Procedure image3.Click
Define Popup raccourci SHORTCUT Relative From Mrow(),Mcol()
Define Bar 1 Of raccourci Prompt "Hide menu" ;
FONT "Courier New", 8 Style "BI"  Color G/w*, B/w*,,,,w+/GR ;
PICTURE (Home(1)+"GRAPHICS\ICONS\INDUSTRY\SINEWAVE.ICO")
Define Bar 2 Of raccourci Prompt "Run vfp9" ;
FONT "Courier New", 8 Style "BI"  Color G/w*, B/w*,,,,w+/GR
Define Bar 3 Of raccourci Prompt "Run explorer" ;
FONT "Courier New", 8 Style "BI"  Color G/w*, B/w*,,,,w+/GR ;
PICTURE  (Home(1)+"GRAPHICS\ICONS\misc\camera.ico")
Define Bar 4 Of raccourci Prompt "Run Mspaint" ;
FONT "Courier New", 8 Style "BI"  Color G/w*, B/w*,,,,w+/GR ;
PICTURE  (Home(1)+"GRAPHICS\ICONS\misc\misc15.ico")
Define Bar 5 Of raccourci Prompt "Run Calculator" ;
FONT "Courier New", 8 Style "BI"  Color G/w*, B/w*,,,,w+/GR ;
PICTURE  (Home(1)+"GRAPHICS\ICONS\misc\volume01.ico")
Define Bar 6 Of raccourci Prompt "yClock-calendar" ;
FONT "Courier New", 8 Style "BI"  Color G/w*, B/w*,,,,w+/GR;
PICTURE  (Home(1)+"GRAPHICS\ICONS\misc\misc01.ico")
Define Bar 7 Of raccourci Prompt "Run Notepad" ;
FONT "Courier New", 8 Style "BI"  Color G/w*, B/w*,,,,w+/GR;
PICTURE  (Home(1)+"GRAPHICS\ICONS\misc\misc02.ico")
Define Bar 8 Of raccourci Prompt "Run Notepad++" ;
FONT "Courier New", 8 Style "BI"  Color G/w*, B/w*,,,,w+/GR;
PICTURE  (Home(1)+"GRAPHICS\ICONS\misc\misc03.ico")
Define Bar 9 Of raccourci Prompt "Horloge Windows" ;
FONT "Courier New", 8 Style "BI"  Color G/w*, B/w*,,,,w+/GR;
PICTURE  (Home(1)+"GRAPHICS\ICONS\misc\misc04.ico")
Define Bar 10 Of raccourci Prompt "Run Wordpad" ;
FONT "Courier New", 8 Style "BI"  Color G/w*, B/w*,,,,w+/GR;
PICTURE  (Home(1)+"GRAPHICS\ICONS\misc\misc05.ico")
Define Bar 11 Of raccourci Prompt "Run yCap" ;
FONT "Courier New", 8 Style "BI"  Color G/w*, B/w*,,,,w+/GR;
PICTURE  (Home(1)+"GRAPHICS\ICONS\misc\misc06.ico")
Define Bar 12 Of raccourci Prompt "Resize images wia" ;
FONT "Courier New", 8 Style "BI"  Color G/w*, B/w*,,,,w+/GR;
PICTURE  (Home(1)+"GRAPHICS\ICONS\misc\misc07.ico")
Define Bar 13 Of raccourci Prompt "yPDFReader" ;
FONT "Courier New", 8 Style "BI"  Color G/w*, B/w*,,,,w+/GR;
PICTURE  (Home(1)+"GRAPHICS\ICONS\misc\misc08.ico")
Define Bar 14 Of raccourci Prompt "Google Earth" ;
FONT "Courier New", 8 Style "BI"  Color G/w*, B/w*,,,,w+/GR;
PICTURE  (Home(1)+"GRAPHICS\ICONS\misc\misc09.ico")
Define Bar 15 Of raccourci Prompt "Windows recorder" ;
FONT "Courier New", 8 Style "BI"  Color G/w*, B/w*,,,,w+/GR;
PICTURE  (Home(1)+"GRAPHICS\ICONS\misc\misc10.ico")
Define Bar 16 Of raccourci Prompt "OpenOffice" ;
FONT "Courier New", 8 Style "BI"  Color G/w*, B/w*,,,,w+/GR;
PICTURE  (Home(1)+"GRAPHICS\ICONS\misc\misc11.ico")
Define Bar 17 Of raccourci Prompt "Paintshop PSp" ;
FONT "Courier New", 8 Style "BI"  Color G/w*, B/w*,,,,w+/GR;
PICTURE  (Home(1)+"GRAPHICS\ICONS\misc\misc12.ico")
Define Bar 18 Of raccourci Prompt "Anim" ;
FONT "Courier New", 8 Style "BI"  Color G/w*, B/w*,,,,w+/GR;
PICTURE  (Home(1)+"GRAPHICS\ICONS\misc\misc13.ico")
Define Bar 19 Of raccourci Prompt "Snipping Tool Capture" ;
FONT "Courier New", 8 Style "BI"  Color G/w*, B/w*,,,,w+/GR;
PICTURE  (Home(1)+"GRAPHICS\ICONS\misc\misc14.ico")
Define Bar 20 Of raccourci Prompt "WMPlayer" ;
FONT "Courier New", 8 Style "BI"  Color G/w*, B/w*,,,,w+/GR;
PICTURE  (Home(1)+"GRAPHICS\ICONS\misc\misc34.ico")
Define Bar 21 Of raccourci Prompt "yMeteo" ;
FONT "Courier New",8 Style "BI"  Color G/w*, B/w*,,,,w+/GR;
PICTURE  (Home(1)+"GRAPHICS\ICONS\misc\misc35.ico")
Define Bar 22 Of raccourci Prompt "DOS CMD.exe" ;
FONT "Courier New",8 Style "BI"  Color G/w*, B/w*,,,,w+/GR;
PICTURE  (Home(1)+"GRAPHICS\ICONS\misc\misc36.ico")
On Selection Bar 1 Of raccourci
On Selection Bar 2 Of raccourci
On Selection Bar 3 Of raccourci
On Selection Bar 4 Of raccourci
On Selection Bar 5 Of raccourci
On Selection Bar 6 Of raccourci
On Selection Bar 7 Of raccourci
On Selection Bar 8 Of raccourci
On Selection Bar 9 Of raccourci
On Selection Bar 10 Of raccourci
On Selection Bar 11 Of raccourci
On Selection Bar 12 Of raccourci
On Selection Bar 13 Of raccourci
On Selection Bar 14 Of raccourci
On Selection Bar 15 Of raccourci
On Selection Bar 16 Of raccourci
On Selection Bar 17 Of raccourci
On Selection Bar 18 Of raccourci
On Selection Bar 19 Of raccourci
On Selection Bar 20 Of raccourci
On Selection Bar 21 Of raccourci
On Selection Bar 22 Of raccourci
Activate Popup raccourci

Thisform.command2.Click()  &&reduce to execute enu option because topmost
Messagebox("can code menu execution....",0+32+4096,'',1000)
Thisform.WindowState=0
Try
yform.WindowState=0
Catch
Endtry
Endproc

Procedure shape3.Click
*create horizontal bmp image   with linear gradient 2 color randomly
Local nWidth,lnHeight As Integer
Set Classlib To Locfile (Home(1)+"ffc\_gdiplus.vcx")
Local    OBitmap, oGraphics, Open, nY,nX, cFileName
*hoprizontal
lnWidth= 130
lnHeight= 30
m.cFileName ="ygradH.bmp"

m.OBitmap = Createobject ("gpBitmap")
m.OBitmap. Create (lnWidth, lnHeight)
m.oGraphics = Createobject ("gpGraphics")
m.oGraphics.CreateFromImage (m.OBitmap)
Local tnRed, tnGreen, tnBlue, tnAlpha,xcolor
tnRed=Int(255*Rand())
tnGreen=Int(255*Rand())
tnBlue=Int(255*Rand())
m.xcolor=Thisform.rgb2html(Rgb(tnRed,tnGreen,tnBlue))
m.xcolor="0x"+Strtran(m.xcolor,"#","") +"00"  &&build a compatible vfp  color like 0xAAAA0000 with html color

m.oPen = Createobject ("gpPen", 0)
For m.nY = 0 To (lnHeight - 1) Step 1
m.oPen.PenColor = Eval(m.xcolor)+ (m.nY * 255 / lnHeight)
m.oGraphics.DrawLine (m.oPen, 0, m.nY, lnWidth - 1, m.nY)
Endfor
m.OBitmap.SaveToFile (m.cFileName, "image/bmp")
* can blur result image here with gdiplusX (for a better effect)

Thisform.image1.Picture=m.cFileName
Thisform.image1.Visible=.T.
m.oPen=Null
m.oGraphics=Null
m.OBitmap=Null
Set Classlib To
Endproc

Procedure shape4.Click
**build a elementary bitmap with dimensions in pixels 256x1
With _Screen
.AddProperty("red1",0)
.AddProperty("green1",0)
.AddProperty("blue1",0)
.AddProperty("red2",0)
.AddProperty("green2",0)
.AddProperty("blue2",0)
Endwith
Local m.xcolor1,m.xcolor2
m.xcolor1=Getcolor()
If m.xcolor1=-1
m.xcolor1=255
Endi

With _Screen
.red1=Asc(Substr(Left(BinToC(m.xcolor1,'R'),3),1,1)) && RED
.green1=Asc(Substr(Left(BinToC(m.xcolor1,'R'),3),2,1)) && GREEN
.blue1=Asc(Substr(Left(BinToC(m.xcolor1,'R'),3),3,1)) && BLUE
Endwith

m.xcolor2=Getcolor()
If m.xcolor2=-1
m.xclor1=255
Endi
With _Screen
.red2=Asc(Substr(Left(BinToC(m.xcolor2,'R'),3),1,1)) && RED
.green2=Asc(Substr(Left(BinToC(m.xcolor2,'R'),3),2,1)) && GREEN
.blue2=Asc(Substr(Left(BinToC(m.xcolor2,'R'),3),3,1)) && BLUE
Endwith
Local m.X
m.X=Int(Val(Inputbox("Gradient horizontal(1)-vertical(2)-diagonam (3)","","2")))
If !Inlist(m.X,1,2,3)
m.X=2
Endi

Do Case
Case m.X=1
*     Horizontal
m.bmp="BM6"+Chr(3)+Replicate(Chr(0),6)+Chr(0x36)+Replicate(Chr(0),3)+ ;
	chr(0x28)+Replicate(Chr(0),4)+Chr(1)+Replicate(Chr(0),2)+ ;
	chr(1)+Replicate(Chr(0),3)+Chr(1)+Chr(0)+Chr(0x18)+Replicate(Chr(0),6)+ ;
	chr(3)+Replicate(Chr(0),18)

For m.i=0 To 255
	m.red=Round(_Screen.red1*(255-m.i)/255+_Screen.red2*m.i/255,0)
	m.blue=Round(_Screen.blue1*(255-m.i)/255+_Screen.blue2*m.i/255,0)
	m.green=Round(_Screen.green1*(255-m.i)/255+_Screen.green2*m.i/255,0)
	m.bmp=m.bmp+Chr(m.blue)+Chr(m.green)+Chr(m.red)
Next

Case m.X=2
*     Vertical
m.bmp="BM6"+Chr(4)+Replicate(Chr(0),6)+Chr(0x36)+Replicate(Chr(0),3)+ ;
	chr(0x28)+Replicate(Chr(0),3)+Chr(1)+Replicate(Chr(0),4)+ ;
	chr(1)+Replicate(Chr(0),2)+Chr(1)+Chr(0)+Chr(0x18)+Replicate(Chr(0),6)+ ;
	chr(4)+Replicate(Chr(0),18)

*!*     Vertical
For m.i=0 To 255
	m.red=Round(_Screen.red1*(255-m.i)/255+_Screen.red2*m.i/255,0)
	m.blue=Round(_Screen.blue1*(255-m.i)/255+_Screen.blue2*m.i/255,0)
	m.green=Round(_Screen.green1*(255-m.i)/255+_Screen.green2*m.i/255,0)
	m.bmp=m.bmp+Chr(m.blue)+Chr(m.green)+Chr(m.red)+Chr(0)
Next

*!* diagonal
Case m.X=3
m.bmp="BM6"+Chr(3)+Replicate(Chr(0),6)+Chr(0x36)+Replicate(Chr(0),3)+ ;
	chr(0x28)+Replicate(Chr(0),4)+Chr(1)+Replicate(Chr(0),2)+ ;
	chr(1)+Replicate(Chr(0),3)+Chr(1)+Chr(0)+Chr(0x18)+Replicate(Chr(0),6)+ ;
	chr(3)+Replicate(Chr(0),18)

For m.i=0 To 255
	m.red=Round(_Screen.red1*(255-m.i)/255+_Screen.red2*m.i/255,0)
	m.blue=Round(_Screen.blue1*(255-m.i)/255+_Screen.blue2*m.i/255,0)
	m.green=Round(_Screen.green1*(255-m.i)/255+_Screen.green2*m.i/255,0)
	m.bmp=m.bmp+Chr(m.blue)+Chr(m.green)+Chr(m.red)
Next
Endcase
Local m.ytemp
m.ytemp=Addbs(Sys(2023))+"bmp"+Sys(2015)+".bmp"
Strtofile(m.bmp,m.ytemp)
* run/n explorer &ytemp
Thisform.image1.Picture=m.ytemp
Thisform.image1.Visible=.T.

Erase (m.ytemp)
Endproc

Procedure spinner2.InteractiveChange
Thisform.Height=This.Value
Try
yform.Resize     &&yaerot.resize()
Catch
Endtry
Endproc

Procedure shape5.Click
With _Screen
.AddProperty("red1",0)
.AddProperty("green1",0)
.AddProperty("blue1",0)
.AddProperty("red2",0)
.AddProperty("green2",0)
.AddProperty("blue2",0)
Endwith
Rand(-1)
Local m.xcolor1,m.xcolor2
m.xcolor1=Rgb(255*Rand(),255*Rand(),255*Rand())     &&getcolor()
If m.xcolor1=-1
m.xcolor1=255
Endi

With _Screen
.red1=Asc(Substr(Left(BinToC(m.xcolor1,'R'),3),1,1)) && RED
.green1=Asc(Substr(Left(BinToC(m.xcolor1,'R'),3),2,1)) && GREEN
.blue1=Asc(Substr(Left(BinToC(m.xcolor1,'R'),3),3,1)) && BLUE
Endwith

m.xcolor2=Rgb(255*Rand(),255*Rand(),255*Rand())     &&getcolor()
If m.xcolor2=-1
m.xclor1=255
Endi
With _Screen
.red2=Asc(Substr(Left(BinToC(m.xcolor2,'R'),3),1,1)) && RED
.green2=Asc(Substr(Left(BinToC(m.xcolor2,'R'),3),2,1)) && GREEN
.blue2=Asc(Substr(Left(BinToC(m.xcolor2,'R'),3),3,1)) && BLUE
Endwith
m.X= Int(3*Rand( ) + 1)  &&random 1,2,3

Do Case
Case m.X=1
*     Horizontal
m.bmp="BM6"+Chr(3)+Replicate(Chr(0),6)+Chr(0x36)+Replicate(Chr(0),3)+ ;
	chr(0x28)+Replicate(Chr(0),4)+Chr(1)+Replicate(Chr(0),2)+ ;
	chr(1)+Replicate(Chr(0),3)+Chr(1)+Chr(0)+Chr(0x18)+Replicate(Chr(0),6)+ ;
	chr(3)+Replicate(Chr(0),18)

For m.i=0 To 255
	m.red=Round(_Screen.red1*(255-m.i)/255+_Screen.red2*m.i/255,0)
	m.blue=Round(_Screen.blue1*(255-m.i)/255+_Screen.blue2*m.i/255,0)
	m.green=Round(_Screen.green1*(255-m.i)/255+_Screen.green2*m.i/255,0)
	m.bmp=m.bmp+Chr(m.blue)+Chr(m.green)+Chr(m.red)
Next

Case m.X=2
*     Vertical
m.bmp="BM6"+Chr(4)+Replicate(Chr(0),6)+Chr(0x36)+Replicate(Chr(0),3)+ ;
	chr(0x28)+Replicate(Chr(0),3)+Chr(1)+Replicate(Chr(0),4)+ ;
	chr(1)+Replicate(Chr(0),2)+Chr(1)+Chr(0)+Chr(0x18)+Replicate(Chr(0),6)+ ;
	chr(4)+Replicate(Chr(0),18)

*!*     Vertical
For m.i=0 To 255
	m.red=Round(_Screen.red1*(255-m.i)/255+_Screen.red2*m.i/255,0)
	m.blue=Round(_Screen.blue1*(255-m.i)/255+_Screen.blue2*m.i/255,0)
	m.green=Round(_Screen.green1*(255-m.i)/255+_Screen.green2*m.i/255,0)
	m.bmp=m.bmp+Chr(m.blue)+Chr(m.green)+Chr(m.red)+Chr(0)
Next

Case m.X=3  	&&diagonal
m.bmp="BM6"+Chr(3)+Replicate(Chr(0),6)+Chr(0x36)+Replicate(Chr(0),3)+ ;
	chr(0x28)+Replicate(Chr(0),4)+Chr(1)+Replicate(Chr(0),2)+ ;
	chr(1)+Replicate(Chr(0),3)+Chr(1)+Chr(0)+Chr(0x18)+Replicate(Chr(0),6)+ ;
	chr(3)+Replicate(Chr(0),18)

For m.i=0 To 255
	m.red=Round(_Screen.red1*(255-m.i)/255+_Screen.red2*m.i/255,0)
	m.blue=Round(_Screen.blue1*(255-m.i)/255+_Screen.blue2*m.i/255,0)
	m.green=Round(_Screen.green1*(255-m.i)/255+_Screen.green2*m.i/255,0)
	m.bmp=m.bmp+Chr(m.blue)+Chr(m.green)+Chr(m.red)
Next

Endcase
Local m.ytemp
m.ytemp=Addbs(Sys(2023))+"bmp"+Sys(2015)+".bmp"
Strtofile(m.bmp,m.ytemp)
* run/n explorer &ytemp


Thisform.image1.Picture=m.ytemp
Thisform.image1.Visible=.T.

Erase (m.ytemp)
Endproc

Procedure shape6.Click
Wait Window "rightclick to restore" Timeout 0.5
=ylightbox ()
Endproc

Procedure my
*LPARAMETERS nButton, nShift, nXCoord, nYCoord
Try
yform.RemoveObject("yimg")
Catch
Endtry
Endproc

Procedure Load
Declare SetWindowLong In Win32Api  Integer, Integer, Integer
Declare SetLayeredWindowAttributes In Win32Api Integer, String, Integer, Integer
Declare Integer GetWindowLong In user32;
INTEGER HWnd, Integer nIndex
Declare Integer SetWindowLong In user32;
INTEGER HWnd, Integer nIndex, Integer dwNewLong
Declare Integer SetLayeredWindowAttributes In user32;
INTEGER HWnd, Integer crKey,;
SHORT bAlpha, Integer dwFlags
Declare Integer ReleaseCapture In WIN32API
Declare Integer SendMessage In WIN32API Integer, Integer, Integer, Integer

Do Locfile("system.app")   &&put system.app in source folder
Endproc

Enddefine
*
*-- EndDefine: yaerot0

*can see my native vfp lightbox with a simlple shape and dramose=9 in
*http://yousfi.over-blog.com/2015/03/form-transparencies-in-visual-foxpro.html

Function ylightbox()
With yform
.ShowTips=.T.
Try
.AddObject("yimg","image")
Catch
Endtry
With .yimg
.Left=0
.Top=0
.Width =yform.Width
.Height=yform.Height
.ZOrder(0)
.ToolTipText="Rightclick to restore"
.Name="yimg"
Endwith
Endwith

Rand(-1)
Local m.xcolor
m.xcolor=Rgb(255*Rand(),255*Rand(),255*Rand())  &&can choose a fixed blacky color as rgb(28,28,28)

Local RGBChr,red,green,blue
m.RGBChr=Left(BinToC(m.xcolor,'R'),3)
m.red=Asc(Substr(m.RGBChr,1,1))
m.green=Asc(Substr(m.RGBChr,2,1))
m.blue=Asc(Substr(m.RGBChr,3,1))

With _Screen.System.Drawing
loClrMatrix = .Imaging.ColorMatrix.New( ;
m.red,       0,      0, 0, 0, ;
0, m.green,      0, 0, 0, ;
0,       0, m.blue, 0, 0, ;
0,       0,      0, 1, 0, ;
0,       0,      0, 0, 1)

loBmp = .Bitmap.FromScreen(yform.HWnd,yform.yimg)    &&loRect)
loBmp.ApplyColorMatrix(loClrMatrix)
loGfx = .Graphics.FromImage(loBmp)
loGfx.FillRectangle(.SolidBrush.New(.Color.FromARGB(210,m.red, m.green, m.blue)), ;
0, 0, yform.Width, yform.Height)
Endwith

With yform.yimg
.PictureVal = loBmp.GetPictureValFromHBitmap()
.ZOrder(0)
.Visible = .T.
Endwith

If Vartype(yform.yimg)="O"
Bindevent(yform.yimg,"rightclick",yform1,"my")

Endi

Endfunc

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

*3* created on Friday 05 of may 2017
*this code builds a button class as container with [label+image+shape].
*images are small pngs encoded strings embed in code (no visual on disc)
*Effects mouseEnter,MouseLeave,click button are binded to procedurs my,my1
*mousemove on any button or click it to see effects.

publi yform
yform=newObject("asup")
yform.show
read events
retu
*
DEFINE CLASS asup AS form
BorderStyle = 0
Height = 377
Width = 555
AutoCenter = .T.
Caption = "Building buttons class -mouseMove  or  click  button"
MaxButton = .F.
BackColor = RGB(0,0,0)
Name = "Form1"

ADD OBJECT container1 AS ybutton  WITH ;
	Top = 12, ;
	Left = 12, ;
	Width = 150, ;
	Height = 40, ;
	BackStyle = 0, ;
	BorderWidth = 0, ;
	Name = "Container1"

ADD OBJECT container2 AS ybutton WITH ;
	Top = 12, ;
	Left = 182, ;
	Width = 150, ;
	Height = 40, ;
	BackStyle = 0, ;
	BorderWidth = 0, ;
	Name = "Container2"

ADD OBJECT container3 AS  ybutton WITH ;
	Top = 12, ;
	Left = 364, ;
	Width = 150, ;
	Height = 40, ;
	BackStyle = 0, ;
	BorderWidth = 0, ;
	Name = "Container3"

ADD OBJECT container4 AS  ybutton WITH ;
	Top = 94, ;
	Left = 12, ;
	Width = 150, ;
	Height = 40, ;
	BackStyle = 0, ;
	BorderWidth = 0, ;
	Name = "Container4"

ADD OBJECT container5 AS  ybutton WITH ;
	Top = 94, ;
	Left = 182, ;
	Width = 150, ;
	Height = 40, ;
	BackStyle = 0, ;
	BorderWidth = 0, ;
	Name = "Container5"

ADD OBJECT container6 AS  ybutton WITH ;
	Top = 94, ;
	Left = 364, ;
	Width = 150, ;
	Height = 40, ;
	BackStyle = 0, ;
	BorderWidth = 0, ;
	Name = "Container6"

ADD OBJECT container7 AS  ybutton WITH ;
	Top = 176, ;
	Left = 12, ;
	Width = 150, ;
	Height = 40, ;
	BackStyle = 0, ;
	BorderWidth = 0, ;
	Name = "Container7"

ADD OBJECT container8 AS  ybutton WITH ;
	Top = 176, ;
	Left = 182, ;
	Width = 150, ;
	Height = 40, ;
	BackStyle = 0, ;
	BorderWidth = 0, ;
	Name = "Container8"

ADD OBJECT container9 AS  ybutton WITH ;
	Top = 176, ;
	Left = 364, ;
	Width = 150, ;
	Height = 40, ;
	BackStyle = 0, ;
	BorderWidth = 0, ;
	Name = "Container9"

ADD OBJECT container10 AS  ybutton WITH ;
	Top = 243, ;
	Left = 12, ;
	Width = 150, ;
	Height = 40, ;
	BackStyle = 0, ;
	BorderWidth = 0, ;
	Name = "Container10"

ADD OBJECT container11 AS  ybutton WITH ;
	Top = 243, ;
	Left = 182, ;
	Width = 150, ;
	Height = 40, ;
	BackStyle = 0, ;
	BorderWidth = 0, ;
	Name = "Container11"

ADD OBJECT container12 AS  ybutton WITH ;
	Top = 243, ;
	Left = 364, ;
	Width = 150, ;
	Height = 40, ;
	BackStyle = 0, ;
	BorderWidth = 0, ;
	Name = "Container12"


ADD OBJECT spinner1 AS spinner WITH ;
	Height = 24, ;
	KeyboardHighValue = 160, ;
	KeyboardLowValue = 75, ;
	Left = 204, ;
	SpinnerHighValue = 160.00, ;
	SpinnerLowValue =  75.00, ;
	Top = 336, ;
	Width = 84, ;
	Value = 100, ;
	Name = "Spinner1"
	
PROCEDURE INIT
local x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11,x12
*button1.png
text to m.x1 noshow
iVBORw0KGgoAAAANSUhEUgAAAJEAAAAoCAYAAAD+HRieAAABY0lEQVR4nO3cMUpdQRiG4XfOmSgESRVi6RYsFIXsIHcRQloREUFcwE3EHVgJ2YM7uKSQBFKnUwKBC1amOgM6Vnap/Itx4H1W8BWHj/P/w0yqtQJASjPgANgE1pH+bwn8AubU+h0g1Vopw3gGnDaNph6drjw+nKd/45sZcNU6jbr0AOzmKQ37rZOoWyNwnP6uvF0CH1qnUbf+pJvVtdo6hfqWSxpbZ1DnchmG1hnUuTzZRArKJdlEisllsIkUYxMpzCZSWJ5sIgW5J1KYeyKF2UQKczpTWJ6czhRkEynMPZHCbCKF+REpzB9rhdlECnPZqDCPPRRmEyksTzaRgmwihTmdKcxjD4XZRArz8qLC3BMpLJc0LvF5Pb3cbS7D8BOYtU6ibi1ySeNX4BOQWqdRdwowT7VW3m/vnQBfgNw4lPpRgMO7H98u0vMTxO92Pm8BR8BHYKNhOL1ut8ACmN9fX/4GeAKfzVQWOamTqAAAAABJRU5ErkJggg==
endtext

*button2.png
text to m.x2 noshow
iVBORw0KGgoAAAANSUhEUgAAAJEAAAAoCAYAAAD+HRieAAABVUlEQVR4nO3cMUpcURhH8fPmXVNahVhJtiDEQpA0lplFCLYiEgRxAaPiDqwC2UPqNIOdYG055YCVYjH3IjdFsLPyK64Xzm8F/+Jx+Hg83lBr5b9hChwBW8AG0tuWwB0wg3oDMNRayWW8BM6aTlOPzj6tvVwNT89rU+BP6zXq0guwk1Zlcth6ibo1Aicpl/Fb6yXq2m7KZfKl9Qp1bTPlMrYeoc6lXCatN6hzaWWJFGSJFOZNpDBLpDBLpLC0skQKskQK8yZSmCVSmCVSmG+sFWaJFOZNpDBLpDAfIoV5WCvMEinMw1phlkhhlkhhfgqiMEukMG8ihVkihVkihfnGWmGWSGEpl3GJv9fT+y1SLpNbYNp6ibo1T7mMF8APYGi9Rt3JwGyotfJ5b/8UOAdS41HqRwaOH/7+vh5ef0G8/v1gG/gJ7AJfG47Tx7YA5sDscf7rHuAfP0t0ArkjZ/MAAAAASUVORK5CYII=
endtext
*button3.png
text to m.x3 noshow
iVBORw0KGgoAAAANSUhEUgAAAJEAAAAoCAYAAAD+HRieAAABSElEQVR4nO3cMUoDQRxG8Tc4gifQ0itYWAhiY2kuIqiICOIBomJvkYNY2wQ7wdoyCEJQsBJDdsNYiJ2V/2IceL8TfMVjlt2FSaUUABIMgCNgA1hD+t0UeASGBe4BUimF1PVXwHnVaWrReVnO14mPzwFwW3uNmrQAtnLq+oPaS9SsJeA0pdf3KbBae42a9ZzSy1upvUJty3R97Q1qnBEpzIgUlpMRKciTSGFGpDAjUpgRKcyIFJZTt6i9QY3zJFKYESnMiBRmRArzt4fCPIkUZkQKMyKFGZHCMn6xVpBvZwrzcaYwI1KYESnMiBRmRArz7UxhnkQKMyKFZbrFFK/X099NMl3/wPd9jdJfjDNdfwnsAan2GjVnDgxTKYWV3cMz4ALIlUepHXPgeHZ3M0o/VxCv7OxvAifANrBecZz+twkwBoaz8egJ4At6yXX6SIl7EAAAAABJRU5ErkJggg==
endtext
*button4.png
text to m.x4 noshow
iVBORw0KGgoAAAANSUhEUgAAAJEAAAAoCAYAAAD+HRieAAACAUlEQVR4nO3cMWgUQRiG4XeWkTsPMSJG7bURRGwsLUwKBU2hggQLQQu1sJAg0ULUJhBQSAqLIGkULBRRkIAEQQNWIoKQwkpQkWARxIDILTNmLTTHcdflx5sMfk+3yxZf8bLLXTGuqio6OVgPnAIOA4NAo+sh+R+UwFfgLXAXeFZB6HzItUfkQiyAs8B1YHtvdkpGvgBnqnX+efvNVkTuZ7MApoHTvd8mmblZNeqjKxetiIqlH1PAuVSrJDtjy30brsLfiIrF7yeB+4lHSX6GlrdsmnFuYbEBfAT6Ew+S/LwHdntCHEYByersAg55QjyWeolkbcgT4p7UKyRrg96FuDX1CsnaNk+ItdQrJGsbPSGmHiGZU0RipojETBGJmXfhV+oNkjm9icRMEYmZIhIzRSRm3ikiMdKbSMwUkZgpIjFTRGLm0T/WYqRfZ2Kmz5mYKSIxU0RipojE6pMnxG/A5tRLJFufvQvxJXA89RLJ1rwnxEcoIlm9e54QHwMfgB2p10h25suHY69dVVXUjl45ATxIvUiyEoF95ZPxd61DrmpHLo0Dl5POkpyMlDO3JqDjzMbawYs3gGuAS7NLMjFSzk5OrFy4ztNj6wMXDgB3gJ09HiZr3xtgtPni9lz7za6IAOr7zxfAADDMn5j2An3/fqOsMUvAAvAUmAXmmq+muoL5DX0lpCQjNMimAAAAAElFTkSuQmCC
endtext
*button5.png
text to m.x5 noshow
iVBORw0KGgoAAAANSUhEUgAAAJEAAAAoCAYAAAD+HRieAAACDElEQVR4nO3csWtTQQDH8e8Lp6atRAmxdddFkOLiH6BdCtJFQYpDoQ46OAihRBpSY21NpUJLB0HERcFBcCoFEQe7iyAUdFURUSpBi4VI73gO2hCSrYe5Hv4+23u84Tf8eL+bLknTlHZ3a7UeYAw4AwwBvR0fyf/gF/AFeA08BJ5dKZe32j9KWku0NDOTAS4BVeBwd3JKRD4BF69OTb1ofdks0UK1mgEeAOPdzyaRuVOcni5tPzRLNF+p3AMuh0ol0blVmp2twN8S1SYnLwCPA4eS+IyU5+ZWkpsTE73Ae+BQ4EASn3fAcWOdG0UFkp05Bgwb69zZ0EkkaiPGWjsYOoVEbcg45/pDp5CoDRjr3L7QKSRqOWOtDR1CImecc6EzSOSMVYnEk+ZMvGnOxJvmTLxpzsSb/kTiTWci8aY/kXjTmUi8ac7Em+ZMvGnOxJvmTLxpzsSb5ky86U8k3nQmEm+aM/H1wVjn6kA+dBKJ1kfjnHsJnAudRKK1Zqy1T1GJZOceJf2Fwl7gLXAkdBqJztrX9fXBJE1TCvn8eeBJ6EQSFQuc/Favv2lecnUwl7sNXAsaS2JS/L6xsQhtdzbu7+u7AVwHkjC5JBLFn5ubi9sPSfvtsdls9hRwHzja5WCy+70CSo1GY7X1ZUeJAPYYkwFOA6P8KdMJ4MC/zyi7zA/gM7AMPAdWt6ztKMxvSqa/H6MBCvoAAAAASUVORK5CYII=
endtext
*button6.png
text to m.x6 noshow
iVBORw0KGgoAAAANSUhEUgAAAJEAAAAoCAYAAAD+HRieAAADmElEQVR4nO3az2scZRzH8ffzzLNbtzZRIlY9eKoXRYoU/AO0l4IWRFFaD4IKehMUGi9itSAqRSp4sdKLRSn+OIgUVDzYexECgXoQi1WJ0kNtk2w3M/P88DA7m9nutrG7yc5M8n2F7M48+xC+kA/f55nZUeHyZa51/PuTrT8591zKymMOuxfC9oFJYgtQsUL9o4l+bjH16b088N2L+w6mA7OKITpx+pQ+z9xLKywfDoS7J1qvqDyF+muKO154+/EjP/aN5yE6/s1n+lfOnkhJni+lQlEbTW45evSJY7P5eS9Er371yseW+OXSKhO10qT1zgdPf/gGdEN06NShZ9tc+bzswkS9TDGz//2D751W7350ZPsF5n8PhDvLLkrUi0b/sos9D5q/7fkDDicBEjfN4+9f4Ld9pmPbTzpC2fWImmqztN900uXdhmbZtYiausrSXnPVLu/UaBq0MDTKrknUhMeREmNJ7jLe+m0ej2WJCEOTFpqo7BpFRVlSUmI8Nh+aNs763gRHQkJCRANDg2yZU2XUKiok4LHEpCQE/MDnfSHKOWISYkBhMBiaRDRQEqgtxWHzJeuG84xPB0NUlOBIiFGoXoeKaCAdajMKOFIcFkeKH9J1hhnaia7H4ohZKQSqiSZCoUetWpQq4Lv9JguNG+mv3FSIivJAASg0EYaICI3pBks6VRU5XLfbpDgcrMM9QuNHDFG/LM9FuheqiAiDkiu+Ccu6TPbru++WsAE3lkfuRGtxJBSfXlLdfpUFSqPRKFkK10Eg9EJSDMxoS9MojFtjY72+HAzZ6ef7qixYqwHTErCe0I1HuCY0oTtWpnVazsZzo6uA/nBF3bH8R/eO6nq1mIcgC8hqSPqPq/3dpnG22gVm3ev/teZioPqPrx82VXjtHxt+VrT6zw294+y9eDZ8Th6QzWDD9kRi66jEcibqbcIba7EZyXImxibLmRibdCIxNgmRGNuaj4IIsRbpRGJssrEW47pgnPWXgJmyKxG19Ydx1v8EPFV2JaK25o1P/ddIiMToTqrb79nRBM4Bu8quRtTO/L8LS7tVCIHpnbc+A3xRdkWiVizw8OLF9pwBWLzY/nLHTGsP8Hq5dYkamV2+1JkDUCGsPpTWmt72FvAmdX1MUEzKa53F+Fh+0hcigGar8QjwCXDfhAsT1XcWmE066Zni4ECIAEwj0sCjwAGyMD0E3LbxNYqKuQIsAN8CPwBnbOoGAvMfgOKO7LcL9dUAAAAASUVORK5CYII=
endtext
*button7.png
text to m.x7 noshow
iVBORw0KGgoAAAANSUhEUgAAAJEAAAAoCAYAAAD+HRieAAAEAUlEQVR4nO3bTWgcZRzH8e+z++zu7OxLXqhvBy/qRRHxoicPaj0EtCAK0npQqlCrp5JDg1obe4gaCqZgwVgK0qKIICJSsKJgDh4UUQsFPYmtSm0sSfZtdmd2d3Y8PNkm6aZp2E13dvT/gWFnhpnsj/DjP8NMooJCgSu9d/pk+k9+eaaB+6hPczsEdsdB4n9AeQp1MUb8xzS5E7dy1xfPj+1qdBy1ukTHPvsgdoEze+o4kwHBzX3NKwaeQv1lM/rcgcenvlqzv12iox8djy3w0/EW9d2hJBSREcc6fHDX0f3t7cslmnp/z2xA/YXQkolIUVhTr+6ePQDLJZp+96WnCUofhh1MRIwa2THx4jun1Mzh12xqP58jCG4IO5OIGBX/lcz9d2vLPbeThhRIdMO/E/f3MZ1yK0/gB2GnEZFV2qGtSuEeEumwk4io8pa269TCPzcST4A9DCl5pig2qdkAtwRu5SZtuX4KfHAuQjIN+W2QSIUdUQyiIADXAacADbe9N69TbnPlILcMpTJYGcjkIZ2HmAojrhgkvg+VJagUwe9464FO1ZqdJ9WKsFQEpcDOQXYYMjlQsT4kFgPDq0JhAZyimUJXoS13nRKtVluEhUWIxSGbh6FRyA6Zgon/Ft+HahkqJXBKUPc2ddr6k2hdTXAuwfwliGvID8HwNshkQSe6Dy7CEwSmNKUClIrgVjecOFdz7Um0riY4Lvw9bzZTFmRzZlJlc6ZYcukbTNUKFJaguAiVMrRaPf9Idf624a1/0qjUSqnyecgNgZ3Z8q8RG2i1TElqDlSrZr1ShkZ9y79Kzd+S7c/jaq1NmUZGwLbBsiGdNovoXgBUHSiXwHHAqZj1qtPVpakbqjBihfvOIxYzUyqbNeWybUjby5MsG2q0gdFqgeeZYniemSylopksjgPNbm5Jto5yLT24L85iMTOpMhnI5U2ptIZkAhJJsCyzJJIQj+g9mOuaxXHWWa+Z9Ubns5lBogIzEKMvHodkcu2SSJjP9mUzmTTHXXne6n3X2m7zfajXzedm1xuNlfVazSy+f31+H3002JNIRIJ20zrsDCLitGdJiURvZBKJnskkEj3TrpRI9Eh7cjkTPZJJJHomk0j0TG6sRa/Oa9eKLwKjYScRkfWH9tL6G+DJsJOIyDqrXUt/gpRIdO+k9tL6U+A34Paw04jIObt3+rvvVRAEHJl84Cng47ATiUhpAvftO/TtGRUs/wnl9JsPvgVMhBpLRMn4xMtzMwCXSwRw6MgjrwMHAfmnMrGR8cl9X8+0N9aUCOCV2bGHgGPAHX0OJgbfD8D+N/aenlu9s6NEAOMnHosBDwM7MWW6Fxi6/hnFgCkCF4DPgS+BubefPdVRmH8Blit6IEsL4TUAAAAASUVORK5CYII=
endtext
*button8.png
text to m.x8 noshow
iVBORw0KGgoAAAANSUhEUgAAAJEAAAAoCAYAAAD+HRieAAAEO0lEQVR4nO3aS2hcVRzH8e+9cyaZTJqODUoadadYdCFuFLLUghS1LhRKsVCpiLqoKEEiiqQSUUoEq+CiSEAaLD4QF6XUJ9itiFCJD4yk1Bqaxjyax0zmde4cF2feM3FqZiYzN/l/4MLc/9xk/nB/+Z+T4TpmaYkKk5NdjIwcZmbmYaLRvRgTrrxIbHmOkyQQuEo4/BN79pxiePhL+vrSFZcVh0hHoy7PH32Gi1PH0Hr3pjYs2p9S0wwMPKWOj35bXM6HKLmy4nLk8BiLC0da0qDwj939b3d+/NlQ7jQfotihAyeZn3u2ZY0Jf7n5lje7P/zoNciGaPmVl55g4sLpVvclfOa+gf2R4TfOqoXffgnz5+/vElStbkn4za8/jy7MXj2nvE/GD+JwEyrQ6paE32S8Oxkf26f07JXHCEqAxAb9fWm/0rPTdxPZ1epWhF/NXN7rTN3Rm6Az1ElfPxImcd0ScViYg8X5FWfyrhtN/o3uHui/FbrkC2pRjYHlazD/D6zF8lWllVu4JhmDS39AT8ROpcgucN0qv0xsK1rD4hwszkM6ZWtFuSkNUU581R6z09CzEyK9sPMGCdR2sxaD+VlYuQYmu2BVyYvygjWCEV+xx1wAdkRsoHoi4DhN6Fq0lOdBbBWiyxBdgVTS1pUDrH+/q0+iqgzEluwRKApU1w5Q8kWlLxkD8RisLtvgJOOFiQNVp041/yNEJZ9eCBRAsBPC3TZQXd0QCsukaleJOMSyoYnHIJMpvBf474mzng2GqIxJl4bKcWyQQuFCsDpC9X+OuH7GQGINUglIJiC5ZkPj6cI1Lg3Z5yqvESGqJh23x+qCPXcDhVB1hCDYYSdYsKM5n7+dpBLZwCQhFbev08nSpQnskGnC/Va61sa6YQykY/Yo5jg2TB2hQqhU9lyml2UMeGkbDJ22/2Yns1MmnShdknJqbIYbqTHLWb0yKUikIFFWdxxQwUKogp12ouUOFYRA0G70/boH07oQEE/bkOhkaT3jrf/zDVqS6tG85axRjIa0rpxg5RzXBitQFDJXFYVN2fPysDluac11bS3/vlN6nu8rY29uJmMnRcaztVzdGPvay9UNZHShrtM2JOVLTrk2CEktSiuf/gVXMIC2N6rKdG9LAdisJaeZ2mM5E762iRtrsVW1/55ItD1ZzkTdJESibhIiUbfaj4IIUYNMIlE3CZGo11/KU+4i0NvqToRvXVZaud8Dj7e6E+FbE0oH3c+REImNG1dauV8AU8Btre5G+M7EsRe/+8ExxjD8/oMHgE9b3ZHwFQ3cO3L0mwuOyT7P8urJfceBl1valvCTwbee++oEQD5EAENjD70ODLMVHnIRzTQ4+vS5E7mTkhABDJ565H7gA+D2TW5MtL8fgaF3njx7vrhYESKAF04/6gIPAAexYboHiDS/R9FmloErwBnga+D8e4fOVATmX7g0kKqRkxr1AAAAAElFTkSuQmCC
endtext
*button9.png
text to m.x9 noshow
iVBORw0KGgoAAAANSUhEUgAAAJEAAAAoCAYAAAD+HRieAAAEXElEQVR4nO3cf0jcdRzH8ef3e5/Tc7RcTsJokhD2u6GjzOXAjUY4yloEUY3oB2vrhz9yf2xUVMhomyBmW5hbf1TECNYfMyw2ZaNRGtYaiozAFmxOSGObnCV5el+/3/7wvnp33undpd598/04OL3v9/P9ft9/vHh/vt73+1WzvF7idfDkx9lXGdgyga/ExCgwMfOAVWClx70zkSTaOODV0S/pqJ50Mk7ncOuJV8teGo17T7GG6HDLUe0y5x//h78qTCY3AXq8BxMpb9yFal9BZlMud7Xt3LrNimWjmEK0+8vdZaN46y3Mu/9zmcIRdPTulWRXHnhmX+d8Y+cMUe2ndZmD/N5s4H96QSsUjqFI+ySXO6vefrHGF21M1BDtatqTP8xgq4V5+6JVKBxBRz+7mtwn6197fyDS+ogher2h5g4vQ99ZWDmLXqFwBA2tP4ubNx7aVX9p1rrwEL28rzLfy9D3EiARTkPrX82aB5vf+uCPkOXBIdr+TlXmVQZ+kilMRKPh+vlG8kqP7G2YPkdSwQOGfP3NkxgSIDEHo2iQi/uBGnuJZlkWjIxQVvHYQ358p5JYnXAMzVzB9YWtH33VC4FOVLS9WAM+1HGhSEOX7xFFBBZgYjCJX/+bkUNkZpZCoBMVludvBY7bg3Vc6Lhwhc52YpmysALhMbAI+RJ7fXfrhS4FMDFmVIRuZkz/ZgdKx4W2BAWL1GFiMomByWS0IZVAl5ZfsiYb+JN5r4Vp6OiBQOkgkfofsjAD0bEww7tOJKNAtvKPGVtI4GKqHSZNzp8cbWqqijk04a4DSpXfZ5QkdviZKU+bfunTn6RTpaqpXmMF4rMA1qkJn1GwEHsKpwW9QA/8FEvHCnSWmfcFCk24AuUfM25ZjD1HYncoO1ASrIVhT0PBoSH+qSlRa5XfZ9ywVEeby0ygtFnvYkroOcuShyWaLM3tUUmvIjbLp2+lSDhiZWo4qFqRksaV26PGAbnBXiTKq9Iy1DBwU7IrEY41rNwedRkJkUhcr3JnqB7ggWRXIhyrR6V51GlgZ7IrEY7VqdwedQKQk2uRiCvAj+riucHR2zbktgPlya5IOE7Lbx0DkwrA7VFNSIhE/BrBvscaKCzPPwesS2ZFwlHaulsvlEHQ0x5uj6oEOpALVmJ+E0C1/WG6EwGUPHfPYWBHEooSzrK384vz79ofQu7ET8tQ1UAhcP9SVyUcox2oDV4Q0okAHq66Lxf4AViy+4yEY/QBJe0Hf7kWvHBWiAAe2VOcB5xBgiRm9AGbvq3rGgxfETFEAE+8tyEH+BooWtzahAO0A88er+24Fmll1BABPLV/YzpwAKhC/r3ecjQB1AG1x948E/XhszlDZNvWuPleoAHYvGDliVTXBlQffeNU33wDYwqR7YXmsmKmnnosB1YmXJ5IVVeAFqDxs1dO/hrrRnGFyLbj80fTgfVAMVAArAWygFXIhVwnGAe8wDDQC/Qw9YfU2SPPfxN12ormX2xhaSrPLQhHAAAAAElFTkSuQmCC
endtext
*button10.png
text to m.x10 noshow
iVBORw0KGgoAAAANSUhEUgAAAJEAAAAoCAYAAAD+HRieAAAEtElEQVR4nO2cf2hVVRzAP+e+S29mazZWzigSYlREMoVMW7Dsl7NYDQKVFoqSs8JtCC7EWmSzVFyxFqy5lWEwMP/JlNKtrCwNS6IxKNhfaYNkbI4n0/betndOf7x7t/ue723vzffrrvOByzv3nHPv/T7eh+89995zn1A+H4nSfOKjgkH6Vo3iL5GMF0vkQmAeKG/CO9NkCBEAfAbGeQOz28uck4XcffyVso1XEt5TvBK1HekQffzxnJ/hLUHGVwBGogfTZDsi4MHsmsPNLXdwX2dVRaWKa6t4JHr98x1l/+JrVMj7rztOjSsQeH7PJb/67TUNZ6btO5VE7xxszBvkr9YgY2uTGqHGNZjc0H4bRTXb19f6Y/WJKdGOtvqiYfqPKdQ9KYtQ4woExrk8Fjy/q+qtvqjt0SSqa95+71UGvgdVmPIINS5BXMhl/qN7a949f01LpERb99UVjTD4o9ICaSIQiAtzmf/we3V7/gmrd0pU0/Ba3gj9v+hTmCYWAvHrXG4vbarfPTFGMp0drgb6WxVBLZBmKpYOc3E3sNWuEEopuHyZDdvWPa4Y+zaDwWncgzS4cfGBxk96wMpEL1ZXCOCD0P1DDyAyGJ8mu5FA0ICRD8nLKwUrE1WuLq0AvpjsaIAwQp9aKA0KCIKSVnmC5R2HT501AaRfbgnfSE4WhSWU8KQ6Uk22oSQoW56oVANnxZqnSgqAfuJ5FiYMMDxWltLMSpR0LNM+OrsCFJjSL1cR98NUCYyHioYHDCO0aNyLUiCDIOOSJpKbgFJTBVTJzI4+PlkUwhJKWNlKi5W1KAlBGZJGxjxNJcISU/plcTL2BMHwVVsqjyWV0AP0tCNVSBqpLGnUTLLNdBSbKqDuSvZeQ0RIJQjJZEtlCCuDabmuG1sQqRxZJumyxGKRKf3ylnQdLeyqz8lExhKOxRYtfdFlLQpr7KIiZLEyTNp8iUq+qQLZMKVVMbVgDsmEJZZwCCfAtbZFyhFtSf4pKJncakp/UgZXmccWSwjrHqmjPCFbjMzmHK9Ftsfaxs4OkZ8weSoJa3OUcQoy0y+cNYyZRo4RALIgGyUb65ezbrZGDtHSjiBcRk9khWvxmcIrhoAFmY5E41qGTCPH+BstkWbm9JjCK7qBhzIdica1dJtGjnES2JzpSDSu5YwpvOI4MEsH15oUMwD8LJRSrF35yFGgPNMRaVxH+6HO01UmgPCKFrREmsRpAnuONVC5uvQ3YEkmI9K4is6Ow6fKwPG2h8gxqoHTzJI7YJqUMgrU2isTmQhg3abH9gNVGQhK4y4aPmv/7k17Jey9M5Fj1AKLgQfTHZXGNXQBO50VYZkIYMO2J+8EfgJSNM9I42J6gZJPG7+55Ky8RiKAjW+sXAj8gBZJM0kvsOLArs6LkQ1RJQJ4qaGsEPgSWJra2DQuoAt44eP6E5eiNcaUCGDTvqe9wB6gBv33ev9HRoG9wM72uq9jTqaZUiKbzc3PPAC8DzyRtPA02U4nULu/5qve6TrGJZHNy23lywi99VgO5M44PE22MgAcAZpaq479Ge9GCUlk8+rBZ73AcmAZUAwsAvKBeegHuW4gAPiAIaAH6CZ0IXWuZf3RhOeA/geXCqymE+9zkwAAAABJRU5ErkJggg==
endtext
*button11.png
text to m.x11 noshow
iVBORw0KGgoAAAANSUhEUgAAAJQAAAAoCAYAAAAYNNPaAAABwElEQVR4nO3cMUscURTF8f9k7iQoogMWEmystIkfwC6IkCKmsFAJaCPERUiTj5HGymabBQkYgqBFgoVtLC0t7NRGEoigsiBmZhgLsxKwCXrhZR/n105zisM7U92krms6rr6+fw40gEVgGHiGyH0XwCGwA6z2vFlrdz4knUK1txvTwBegN0RC6Vo/gHd9M81v8KdQ55tLC8A68CRoNOlW18BUPtvaS35tLOTAMTAQNpN0uTNgxKqi+IDKJI83CMxZVRZToZNINFasLIsXoVNINEatKov+0CkkGv1WlUXoEBIRK1UocaQXSlxZVfwOnUEioskTV5o8caVCiSsVSlzpH0pcWVWoUOJHkyeuNHniSi+UuLLUstAZJCJmKpQ40gslrizNVCjxo8kTV5o8caVCiSsVSlzpH0pcWZo9DZ1BIqLJE1eaPHFlqWXX6LCY+Dix1LJjYCx0EonCvpllLeBj6CQShd3k5/p8DhwBeeg00tUOgfGkrmvOPi9OcnuAU/9S8hCXwPTg20/f7462nm8uvQaa3F7/FflXp8CrfLZ1AH9dAQZobzd6gGVgAngJDAUIKP+/C+AAWAO2+maadwcybgDQIHzWrpJYGwAAAABJRU5ErkJggg==
endtext

*button12.png
text to m.x12 noshow
iVBORw0KGgoAAAANSUhEUgAAAJEAAAAoCAYAAAD+HRieAAACDElEQVR4nO3csWtTQQDH8e8Lp6atRAmxdddFkOLiH6BdCtJFQYpDoQ46OAihRBpSY21NpUJLB0HERcFBcCoFEQe7iyAUdFURUSpBi4VI73gO2hCSrYe5Hv4+23u84Tf8eL+bLknTlHZ3a7UeYAw4AwwBvR0fyf/gF/AFeA08BJ5dKZe32j9KWku0NDOTAS4BVeBwd3JKRD4BF69OTb1ofdks0UK1mgEeAOPdzyaRuVOcni5tPzRLNF+p3AMuh0ol0blVmp2twN8S1SYnLwCPA4eS+IyU5+ZWkpsTE73Ae+BQ4EASn3fAcWOdG0UFkp05Bgwb69zZ0EkkaiPGWjsYOoVEbcg45/pDp5CoDRjr3L7QKSRqOWOtDR1CImecc6EzSOSMVYnEk+ZMvGnOxJvmTLxpzsSb/kTiTWci8aY/kXjTmUi8ac7Em+ZMvGnOxJvmTLxpzsSb5ky86U8k3nQmEm+aM/H1wVjn6kA+dBKJ1kfjnHsJnAudRKK1Zqy1T1GJZOceJf2Fwl7gLXAkdBqJztrX9fXBJE1TCvn8eeBJ6EQSFQuc/Favv2lecnUwl7sNXAsaS2JS/L6xsQhtdzbu7+u7AVwHkjC5JBLFn5ubi9sPSfvtsdls9hRwHzja5WCy+70CSo1GY7X1ZUeJAPYYkwFOA6P8KdMJ4MC/zyi7zA/gM7AMPAdWt6ztKMxvSqa/H6MBCvoAAAAASUVORK5CYII=
endtext

with thisform
for i=1 to .controlcount
if lower(.controls(i).name)=="container"+trans(i)
with .controls(i).label1
dodefault()
.fontsize=9
.fontunderline=.t.
.width=100
.height=40
.left=(.parent.width-.width)/2
.top=(.parent.height-.height)/2
.caption="Command"+trans(i)
endwith
m.y=eval("x"+trans(i))
with .controls(i)
.image1.pictureVal=strconv(m.y,14)
.image1.backstyle=0
.shape1.backcolor=rgb(255*rand(),255*rand(),255*rand())
.shape1.backstyle=1
bindevent(.shape1,"mouseEnter",thisform,"my")
bindevent(.shape1,"mouseLeave",thisform,"my1")
.refresh
endwith
endi
endfor
endwith

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

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

PROCEDURE spinner1.InteractiveChange
	with thisform
	for i=1 to .controlcount
	if lower(.controls(i).name)== "container" +trans(i)    &&container"

	with .controls(i)
	.width=this.value
	.label1.left=(.width-.label1.width)/2
	.label1.top=(.height-.label1.height)/2
	.refresh
	endwith
	endi
	endfor
	endwith
ENDPROC

Procedure destroy
clea events
endproc

ENDDEFINE
*
*-- EndDefine: asup

*
DEFINE CLASS ybutton AS container
Top = 12
Left = 12
Width = 150
Height = 40
BackStyle = 0
BorderWidth = 0
Name = "Container1"

ADD OBJECT shape1 AS shape WITH ;
	Top = 0, ;
	Left = 0, ;
	Height = 61, ;
	Width = 193, ;
	Anchor = 15, ;
	BackStyle = 0, ;
	BorderWidth = 1, ;
	Curvature = 15, ;
	MousePointer = 15, ;
	Name = "Shape1"

ADD OBJECT image1 AS image WITH ;
	Stretch = 2, ;
	Height = 100, ;
	Left = -5, ;
	Top = -12, ;
	Width = 240, ;
	Name = "Image1"

ADD OBJECT label1 AS label WITH ;
	AutoSize = .T., ;
	FontBold = .T., ;
	FontSize = 12, ;
	Alignment = 2, ;
	BackStyle = 0, ;
	Caption = "Actions to code", ;
	Height = 22, ;
	Left = 36, ;
	MousePointer = 15, ;
	Top = 12, ;
	Width = 121, ;
	ForeColor = RGB(0,255,0), ;
	Name = "Label1"

PROCEDURE shape1.Click
	messagebox("do some code from here",0+32+4096,"",1000)
ENDPROC

PROCEDURE shape1.Init
	with this
	.left=0
	.top=0
	.width=.parent.width
	.height=.parent.height
	.zorder(0)
	.curvature=10
	.mousepointer=15
	.borderwidth=1
	endwith
ENDPROC

PROCEDURE shape1.MouseEnter
	LPARAMETERS nButton, nShift, nXCoord, nYCoord
	this.parent.image1.visible=.t.
	this.borderStyle=0
ENDPROC

PROCEDURE shape1.MouseLeave
	LPARAMETERS nButton, nShift, nXCoord, nYCoord
	this.parent.image1.visible=.f.
	this.borderStyle=1
ENDPROC

PROCEDURE image1.Init
	with this
	.anchor=15
	.left=0
	.top=0
	.width=.parent.width
	.height=.parent.height
	.stretch=2
	.visible=.f.
	.zorder(1)
	endwith
ENDPROC

PROCEDURE image1.Click
	with this
	.anchor=15
	.stretch=2
	.left=0
	.top=0
	.width=.parent.width0
	.height=.parent.height0
	.zorder(1)
	endwith
ENDPROC

PROCEDURE label1.Click
	this.parent.shape1.click()
ENDPROC

PROCEDURE label1.MouseLeave
	LPARAMETERS nButton, nShift, nXCoord, nYCoord
	this.parent.shape1.mouseLeave()
ENDPROC

PROCEDURE label1.MouseEnter
	LPARAMETERS nButton, nShift, nXCoord, nYCoord
	this.parent.shape1.mouseEnter()
ENDPROC

PROCEDURE label1.Init
	with this
	.left=(.parent.width-.width)/2
	.top=(.parent.height-.height)/2
	.zorder(0)
	endwith
ENDPROC

ENDDEFINE
*
*-- EndDefine: ybutton

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


*4* Created on saturday 06 of may 2017
*!*	this code build a basic  special menu (similar to office)
*!*	it uses 2 containers one for the header and another for the menu
*!*	2 images are used ans transparent shapes to accomplish the goal instead
*!*	of building complex classes for each component.its very easy to do for the common of mortals.
!*! see also the special effect i used in shape to highLight any menu option.
*!*	its a simple demo ,can customize all what can be customizable in the class and adapt images to the context.

set defa to addbs(justpath(sys(16,1)))
local m.ydownl
m.ydownl=.t.    &&put it to .t. first time only-once images downloaded put it to .f.
if m.ydownl=.t.
*first download 2 images used in code
*download the picture used in code.if dont have internet connect , replace by a local image named yimage.jpg
Declare Integer URLDownloadToFile In urlmon.Dll Integer pCaller, String szURL, String szFileName, Integer dwReserved, Integer lpfnCB
Declare Integer DeleteUrlCacheEntry In wininet String lpszUrlName

Local lcDownloadURL,lcDownloadLoc,lnResult
for i=1 to 2
do case
case i=1
lcDownloadURL = "http://img.over-blog-kiwi.com/1/43/54/07/20170506/ob_b85844_yword-menu.png"
lcDownloadLoc = "yword_menu.png"

case i=2
lcDownloadURL = "http://img.over-blog-kiwi.com/1/43/54/07/20170506/ob_59cf6b_yword-menu0.png"
lcDownloadLoc = "yword_menu0.png"
endcase
lnResult = DeleteUrlCacheEntry(lcDownloadURL)
lnResult = URLDownloadToFile(0, lcDownloadURL, lcDownloadLoc , 0,0)
If lnResult = 0
Wait Window "Download  yimage.jpg  Complete" nowait
*Else
*!*        Messagebox("Download fails")
Endi

endfor
endi


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

Define Class ymenu As Form
	Height = 523
	Width = 689
	ShowWindow = 2
	AutoCenter = .T.
	Caption = "A special menu with containers"
	BackColor = Rgb(212,210,208)
	Name = "Form1"

	Add Object ycnt1 As cnt1 With ;
		Top = 55, ;
		Left = 8, ;
		Width = 408, ;
		Height = 432, ;
		BackStyle = 0, ;
		BorderWidth = 0, ;
		Visible = .F., ;
		Name = "ycnt1"

	Add Object ycnt0 As cnt0 With ;
		Top = 8, ;
		Left = 7, ;
		Width = 401, ;
		Height = 48, ;
		BackStyle = 0, ;
		BorderWidth = 0, ;
		Name = "ycnt0"

	Procedure my
	Lparameters nButton, nShift, nXCoord, nYCoord
*--- aevent create an array laEvents
	Aevents( myArray, 0)
*--- reference the calling object
	loObject = myArray[1]
	loObject.Parent.label1.ForeColor=Rgb(255*Rand(),255*Rand(),255*Rand())
	Local N
	N=Int(Val(Substr(loObject.Name,6)))

	If ! N=9
		loObject.Parent.label1.Caption="Run some codes from here!"
	Else
		loObject.Parent.Visible=.F.
	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
		.DrawMode=9
		.BackColor=255
		.BackStyle=1
		.Curvature=15
	Endwith
	Local N
	N=Int(Val(Substr(loObject.Name,6)))
	loObject.Parent.label1.ForeColor=Rgb(255*Rand(),255*Rand(),255*Rand())
	loObject.Parent.label1.FontSize=24
	Do Case

	Case Between( N,1,8)
		loObject.Parent.label1.FontSize=24
		loObject.Parent.label1.Caption="Menu"+Substr(loObject.Name,6)+" clicked!"+Chr(13)+"Can run some code frome here..."

	Case N=9
		loObject.Parent.label1.FontSize=24
		loObject.Parent.label1.Caption="Close the menu"

	Case N=10
		TEXT to m.myvar noshow
		Lorem ipsum dolor sit amet, consectetur adipiscing elit. Proin vel risus eget lorem feugiat
		fermentum nec a turpis. Phasellus purus sem, mollis ac posuere eget, ornare vel orci.
		ENDTEXT
		loObject.Parent.label1.FontSize=14
		loObject.Parent.label1.Caption=m.myvar
	Endcase
	Endproc

	Procedure my2
	Lparameters nButton, nShift, nXCoord, nYCoord
*--- aevent create an array laEvents
	Aevents( myArray, 0)
*--- reference the calling object
	loObject = myArray[1]
	loObject.DrawMode=13
	loObject.BackStyle=0
	loObject.Parent.label1.Caption=""
	Endproc

	Procedure Destroy
	Clea Events
	Endproc

Enddefine
*
*-- EndDefine: ymenu

*
Define Class  cnt1 As Container
	Top = 55
	Left = 8
	Width = 408
	Height = 432
	BackStyle = 0
	BorderWidth = 0
	Visible = .F.
	Name = "ycnt1"

	Add Object image1 As Image With ;
		Picture = "yword_menu.png", ;
		Stretch = 0, ;
		Height = 424, ;
		Left = 0, ;
		Top = 0, ;
		Width = 400, ;
		Name = "Image1"

	Add Object image2 As Image With ;
		Picture = "", ;
		Stretch = 2, ;
		Height = 46, ;
		Left = 118, ;
		Top = 7, ;
		Width = 277, ;
		Name = "Image2"

	Add Object shape1 As Shape With ;
		Top = 6, ;
		Left = 6, ;
		Height = 36, ;
		Width = 85, ;
		BackStyle = 0, ;
		BorderStyle = 0, ;
		BorderWidth = 0, ;
		MousePointer = 15, ;
		Name = "Shape1"

	Add Object shape2 As Shape With ;
		Top = 97, ;
		Left = 9, ;
		Height = 37, ;
		Width = 85, ;
		BackStyle = 0, ;
		BorderStyle = 0, ;
		MousePointer = 15, ;
		Name = "Shape2"

	Add Object shape3 As Shape With ;
		Top = 49, ;
		Left = 7, ;
		Height = 37, ;
		Width = 85, ;
		BackStyle = 0, ;
		BorderStyle = 0, ;
		MousePointer = 15, ;
		Name = "Shape3"

	Add Object shape4 As Shape With ;
		Top = 136, ;
		Left = 11, ;
		Height = 37, ;
		Width = 90, ;
		BackStyle = 0, ;
		BorderStyle = 0, ;
		MousePointer = 15, ;
		Name = "Shape4"

	Add Object shape5 As Shape With ;
		Top = 180, ;
		Left = 11, ;
		Height = 37, ;
		Width = 90, ;
		BackStyle = 0, ;
		BorderStyle = 0, ;
		MousePointer = 15, ;
		Name = "Shape5"

	Add Object shape6 As Shape With ;
		Top = 224, ;
		Left = 13, ;
		Height = 37, ;
		Width = 90, ;
		BackStyle = 0, ;
		BorderStyle = 0, ;
		MousePointer = 15, ;
		Name = "Shape6"

	Add Object shape7 As Shape With ;
		Top = 265, ;
		Left = 11, ;
		Height = 37, ;
		Width = 94, ;
		BackStyle = 0, ;
		BorderStyle = 0, ;
		MousePointer = 15, ;
		Name = "Shape7"

	Add Object shape8 As Shape With ;
		Top = 310, ;
		Left = 4, ;
		Height = 37, ;
		Width = 108, ;
		BackStyle = 0, ;
		BorderStyle = 0, ;
		MousePointer = 15, ;
		Name = "Shape8"

	Add Object shape9 As Shape With ;
		Top = 351, ;
		Left = 9, ;
		Height = 37, ;
		Width = 90, ;
		BackStyle = 0, ;
		BorderStyle = 0, ;
		MousePointer = 15, ;
		Name = "Shape9"

	Add Object shape10 As Shape With ;
		Top = 393, ;
		Left = 216, ;
		Height = 25, ;
		Width = 180, ;
		BackStyle = 0, ;
		BorderStyle = 0, ;
		Name = "Shape10"

	Add Object label1 As Label With ;
		FontSize = 24, ;
		WordWrap = .T., ;
		BackStyle = 0, ;
		Caption = "", ;
		Height = 228, ;
		Left = 120, ;
		Top = 84, ;
		Width = 276, ;
		ForeColor = Rgb(128,0,64), ;
		Name = "Label1"

	Add Object image3 As Image With ;
		Picture = "", ;
		Stretch = 2, ;
		Height = 46, ;
		Left = 118, ;
		Top = 346, ;
		Width = 277, ;
		Name = "Image3"

	Procedure Init
	local m.myv
	text to m.myv noshow
	iVBORw0KGgoAAAANSUhEUgAAAJEAAAAoCAYAAAD+HRieAAAEO0lEQVR4nO3aS2hcVRzH8e+9cyaZTJqODUoadadYdCFuFLLUghS1LhRKsVCpiLqoKEEiiqQSUUoEq+CiSEAaLD4QF6XUJ9itiFCJD4yk1Bqaxjyax0zmde4cF2feM3FqZiYzN/l/4MLc/9xk/nB/+Z+T4TpmaYkKk5NdjIwcZmbmYaLRvRgTrrxIbHmOkyQQuEo4/BN79pxiePhL+vrSFZcVh0hHoy7PH32Gi1PH0Hr3pjYs2p9S0wwMPKWOj35bXM6HKLmy4nLk8BiLC0da0qDwj939b3d+/NlQ7jQfotihAyeZn3u2ZY0Jf7n5lje7P/zoNciGaPmVl55g4sLpVvclfOa+gf2R4TfOqoXffgnz5+/vElStbkn4za8/jy7MXj2nvE/GD+JwEyrQ6paE32S8Oxkf26f07JXHCEqAxAb9fWm/0rPTdxPZ1epWhF/NXN7rTN3Rm6Az1ElfPxImcd0ScViYg8X5FWfyrhtN/o3uHui/FbrkC2pRjYHlazD/D6zF8lWllVu4JhmDS39AT8ROpcgucN0qv0xsK1rD4hwszkM6ZWtFuSkNUU581R6z09CzEyK9sPMGCdR2sxaD+VlYuQYmu2BVyYvygjWCEV+xx1wAdkRsoHoi4DhN6Fq0lOdBbBWiyxBdgVTS1pUDrH+/q0+iqgzEluwRKApU1w5Q8kWlLxkD8RisLtvgJOOFiQNVp041/yNEJZ9eCBRAsBPC3TZQXd0QCsukaleJOMSyoYnHIJMpvBf474mzng2GqIxJl4bKcWyQQuFCsDpC9X+OuH7GQGINUglIJiC5ZkPj6cI1Lg3Z5yqvESGqJh23x+qCPXcDhVB1hCDYYSdYsKM5n7+dpBLZwCQhFbev08nSpQnskGnC/Va61sa6YQykY/Yo5jg2TB2hQqhU9lyml2UMeGkbDJ22/2Yns1MmnShdknJqbIYbqTHLWb0yKUikIFFWdxxQwUKogp12ouUOFYRA0G70/boH07oQEE/bkOhkaT3jrf/zDVqS6tG85axRjIa0rpxg5RzXBitQFDJXFYVN2fPysDluac11bS3/vlN6nu8rY29uJmMnRcaztVzdGPvay9UNZHShrtM2JOVLTrk2CEktSiuf/gVXMIC2N6rKdG9LAdisJaeZ2mM5E762iRtrsVW1/55ItD1ZzkTdJESibhIiUbfaj4IIUYNMIlE3CZGo11/KU+4i0NvqToRvXVZaud8Dj7e6E+FbE0oH3c+REImNG1dauV8AU8Btre5G+M7EsRe/+8ExxjD8/oMHgE9b3ZHwFQ3cO3L0mwuOyT7P8urJfceBl1valvCTwbee++oEQD5EAENjD70ODLMVHnIRzTQ4+vS5E7mTkhABDJ565H7gA+D2TW5MtL8fgaF3njx7vrhYESKAF04/6gIPAAexYboHiDS/R9FmloErwBnga+D8e4fOVATmX7g0kKqRkxr1AAAAAElFTkSuQmCC
    endtext
     this.image2.pictureVal=strconv(m.myv,14)
     this.image3.pictureVal=strconv(m.myv,14)
    	
	
	
	With This
		For i=1 To .ControlCount
			If Lower(.Controls(i).Class)=="shape"
				Bindevent(.Controls(i),"mousedown",Thisform,"my")
				Bindevent(.Controls(i),"mouseEnter",Thisform,"my1")
				Bindevent(.Controls(i),"mouseLeave",Thisform,"my2")
			Endi
		Endfor
	Endwith
	Endproc

Enddefine
*enddefine cnt1
*
Define Class cnt0  As Container
	Top = 8
	Left = 7
	Width = 401
	Height = 48
	BackStyle = 0
	BorderWidth = 0
	Name = "ycnt0"

	Add Object image1 As Image With ;
		Picture = "yword_menu0.png", ;
		Stretch = 0, ;
		Height = 47, ;
		Left = 0, ;
		Top = 0, ;
		Width = 400, ;
		Name = "Image1"

	Add Object shape1 As Shape With ;
		Top = 0, ;
		Left = 0, ;
		Height = 49, ;
		Width = 45, ;
		BackStyle = 0, ;
		BorderStyle = 0, ;
		BorderWidth = 0, ;
		MousePointer = 15, ;
		Name = "Shape1"

	Add Object shape2 As Shape With ;
		Top = 0, ;
		Left = 50, ;
		Height = 25, ;
		Width = 121, ;
		BackStyle = 0, ;
		BorderStyle = 0, ;
		Name = "Shape2"

	Add Object spinner1 As Spinner With ;
		BorderStyle = 1, ;
		Height = 24, ;
		Left = 369, ;
		MousePointer = 15, ;
		Top = 8, ;
		Width = 21, ;
		BorderColor = Rgb(100,100,100), ;
		Name = "Spinner1"

	Procedure shape1.Click
	Thisform.ycnt1.Visible=Iif(Thisform.ycnt1.Visible=.F.,.T.,.F.)
	Endproc

	Procedure shape2.Click
	Messagebox("no option coded here",0+232+4096,1200)
	Endproc

	Procedure spinner1.UpClick
	If Thisform.ycnt1.Visible=.T.
		Thisform.ycnt1.Visible=.F.
	Endi
	Endproc

	Procedure spinner1.DownClick
	If Thisform.ycnt1.Visible=.F.
		Thisform.ycnt1.Visible=.T.
	Endi
	Endproc

Enddefine
*
*-- EndDefine: cnt0

See the special effect i used with transparent shapes to highlight the menu options.

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



*5* created on monday 08 of may 2017 -updated on 10 of may 2017
*!*	this code builds another special menu with a simple image positionned in a container and overlapped with some shapes.
*!*	adding a shape with each menu item and playing with shape drawMode property and bindevent() function.
*!*	can build as well any modern menu (even office Ribbons with simple image !...)
*!* images here are loaded with no disc access (from the web store)-i made 4 images styles(to change with  spnner1).
*!* added a button to collapse/expand the built menu (as bootstrap navigation does)

Publi m.yrep
m.yrep=Addbs(Justpath(Sys(16,1)))
Set Defa To (yrep)

Publi yform
yform=Newobject("Smenu")
yform.Show
Read Events
Retu
*
Define Class Smenu As Form
	Height = 500
	Width = 919
	ShowWindow = 2
	AutoCenter = .T.
	Caption = "A special menu with shape drawmode effect.click on menu button (o collapse/expand menu (as bootstrap)."
	BackColor = Rgb(212,210,208)
	Name = "Form1"
	xleft=0
	xwidth=0
	ycl=0

	Add Object container1 As ycont With ;
		Top = 0, ;
		Left = 12, ;
		Width = 192, ;
		Height = 500, ;
		BackStyle = 0, ;
		BorderWidth = 0, ;
		Name = "Container1"

	Add Object "yec1" As "yec"  With ;
		visible=.T.,;
		name="yec"

	Add Object label1 As Label With ;
		AutoSize = .T., ;
		FontBold = .T., ;
		FontSize = 32, ;
		BackStyle = 0, ;
		Caption = "Do some code from here !", ;
		Height = 54, ;
		Left = 300, ;
		Top = 120, ;
		Visible = .F., ;
		Width = 531, ;
		ForeColor = Rgb(128,0,64), ;
		Name = "Label1"

	Add Object label2 As Label With ;
		AutoSize = .T., ;
		FontBold = .T., ;
		FontSize = 32, ;
		BackStyle = 0, ;
		Caption = "Do some code from here !", ;
		Height = 54, ;
		Left = 295, ;
		Top = 124, ;
		Visible = .F., ;
		Width = 531, ;
		ForeColor = Rgb(0,255,0), ;
		Name = "Label2"

	Add Object label3 As Label With ;
		FontSize = 11, ;
		BackStyle = 0, ;
		Caption = "Label3", ;
		Height = 73, ;
		Left = 300, ;
		Top = 348, ;
		Width = 589, ;
		ForeColor = Rgb(128,0,64), ;
		wordwrap=.T., ;
		Name = "Label3"

	Add Object label4 As Label With ;
		AutoSize = .T., ;
		FontBold = .T., ;
		FontSize = 16, ;
		BackStyle = 0, ;
		Caption = "", ;
		Height = 27, ;
		Left = 468, ;
		Top = 36, ;
		Visible = .F., ;
		Width = 2, ;
		ForeColor = Rgb(255,0,0), ;
		Name = "Label4"

	Procedure my
	Lparameters nButton, nShift, nXCoord, nYCoord
*--- aevent create an array laEvents
	Aevents( myArray, 0)
*--- reference the calling object
	loObject = myArray[1]
	Local m.x
	m.x=Substr(loObject.Name,6)
	Set Curs Off
	With Thisform
		.label1.Visible=.T.
		.label2.Visible=.T.
		.label4.Caption="Item"+Trans(m.x)+" clicked."
		.label4.Visible=.T.
	Endwith
	Endproc

	Procedure my1
	Lparameters nButton, nShift, nXCoord, nYCoord
*mouseEnter
*--- aevent create an array laEvents
	Aevents( myArray, 0)
*--- reference the calling object
	loObject = myArray[1]
	With loObject
		.BackStyle=1
	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
		.BackStyle=0
	Endwith
	With Thisform
		.label1.Visible=.F.
		.label2.Visible=.F.
		.label4.Visible=.F.
	Endwith
	Set Curs On
	Endproc

	Procedure Destroy
	Clea Events
	Endproc

	Procedure container1.Init
	With This.image1
		.Left=0
		.Top=0
		.Stretch=0
		.ZOrder(1)
	Endwith
	This.SetAll("mousepointer",15,"shape")
	For i=1 To 13
		With Eval("this.shape"+Trans(i))
			.BorderStyle=0
			.BackStyle=0
			.DrawMode=9
			.BackColor=255
			.Curvature=15
			.ZOrder(0)
		Endwith
		Bindevent(Eval("this.shape"+Trans(i)),"mouseDown",Thisform,"my")
		Bindevent(Eval("this.shape"+Trans(i)),"mouseEnter",Thisform,"my1")
		Bindevent(Eval("this.shape"+Trans(i)),"mouseLeave",Thisform,"my2")
	Endfor
	This.spinner1.InteractiveChange()
	Endproc

	Procedure label3.Init
	TEXT to this.caption noshow
	with a simple image designed as decorated menu ,can place it in a container
  and	cover subtitles with shapes with particular properties as mouseEnter/mouseLeave  and  	the  function bindevent().
  -can simulate any modern menu with this trick.
	ENDTEXT
	Endproc

Enddefine
*
*-- EndDefine:smenu

Define Class ycont As Container
	Top = 0
	Left = 12
	Width = 192
	Height = 480
	BackStyle = 0
	BorderWidth = 0
	Name = "ycont"

	Add Object image1 As Image With ;
		Picture = "ylist0.png", ;
		BackStyle = 0, ;
		Height = 425, ;
		Left = 0, ;
		Top = 0, ;
		Width = 183, ;
		Name = "Image1"

	Add Object shape1 As Shape With ;
		Top = 59, ;
		Left = 6, ;
		Height = 25, ;
		Width = 169, ;
		Name = "Shape1"

	Add Object shape2 As Shape With ;
		Top = 85, ;
		Left = 6, ;
		Height = 25, ;
		Width = 169, ;
		Name = "Shape2"

	Add Object shape3 As Shape With ;
		Top = 111, ;
		Left = 5, ;
		Height = 25, ;
		Width = 169, ;
		Name = "Shape3"

	Add Object shape4 As Shape With ;
		Top = 139, ;
		Left = 6, ;
		Height = 25, ;
		Width = 169, ;
		Name = "Shape4"

	Add Object shape5 As Shape With ;
		Top = 165, ;
		Left = 4, ;
		Height = 25, ;
		Width = 169, ;
		Name = "Shape5"

	Add Object shape6 As Shape With ;
		Top = 191, ;
		Left = 5, ;
		Height = 25, ;
		Width = 169, ;
		Name = "Shape6"

	Add Object shape7 As Shape With ;
		Top = 219, ;
		Left = 4, ;
		Height = 25, ;
		Width = 169, ;
		Name = "Shape7"

	Add Object shape8 As Shape With ;
		Top = 248, ;
		Left = 5, ;
		Height = 25, ;
		Width = 169, ;
		Name = "Shape8"

	Add Object shape9 As Shape With ;
		Top = 274, ;
		Left = 4, ;
		Height = 25, ;
		Width = 169, ;
		Name = "Shape9"

	Add Object shape10 As Shape With ;
		Top = 302, ;
		Left = 5, ;
		Height = 25, ;
		Width = 169, ;
		Name = "Shape10"

	Add Object shape11 As Shape With ;
		Top = 327, ;
		Left = 4, ;
		Height = 25, ;
		Width = 169, ;
		Name = "Shape11"

	Add Object shape12 As Shape With ;
		Top = 355, ;
		Left = 5, ;
		Height = 25, ;
		Width = 169, ;
		Name = "Shape12"

	Add Object shape13 As Shape With ;
		Top = 385, ;
		Left = 6, ;
		Height = 25, ;
		Width = 169, ;
		Name = "Shape13"

	Add Object spinner1 As Spinner With ;
		Height = 24, ;
		KeyboardHighValue = 3, ;
		KeyboardLowValue = 0, ;
		Left = 66, ;
		SpinnerHighValue =   3.00, ;
		SpinnerLowValue =   0.00, ;
		Top = 430, ;
		Width = 42, ;
		Value = 0, ;
		Name = "Spinner1"


	Add Object label1 As Label With ;
		AutoSize = .T., ;
		FontBold = .T., ;
		FontSize = 10, ;
		BackStyle = 0, ;
		Caption = "Style(0-3)", ;
		Height = 18, ;
		Left = 10, ;
		Top = 430, ;
		Width = 60, ;
		ForeColor = Rgb(255,0,0), ;
		Name = "Label1"

	Procedure spinner1.InteractiveChange
*some images from  my blog (internet must be connected )
	Local m.lcURL
	Do Case
	Case This.Value=0
		m.lcURL="http://img.over-blog-kiwi.com/1/43/54/07/20170508/ob_c51d41_ylist0.png"
	Case This.Value=1
		m.lcURL="http://img.over-blog-kiwi.com/1/43/54/07/20170508/ob_7f5213_ylist1.png"
	Case This.Value=2
		m.lcURL="http://img.over-blog-kiwi.com/1/43/54/07/20170508/ob_1019f1_ylist2.png"
	Case This.Value=3
		m.lcURL="http://img.over-blog-kiwi.com/1/43/54/07/20170508/ob_258c66_ylist3.png"
	Endcase
	This.Parent.image1.PictureVal=yloadImg(m.lcURL)
	Endproc

	Procedure Init
	With This.image1
		.Left=0
		.Top=0
		.Stretch=0
		.ZOrder(1)
	Endwith
	This.SetAll("mousepointer",15,"shape")
	For i=1 To 13
		With Eval("this.shape"+Trans(i))
			.BorderStyle=0
			.BackStyle=0
			.DrawMode=9
			.BackColor=255
			.Curvature=15
			.ZOrder(0)
		Endwith
		Bindevent(Eval("this.shape"+Trans(i)),"mouseDown",Thisform,"my")
		Bindevent(Eval("this.shape"+Trans(i)),"mouseEnter",Thisform,"my1")
		Bindevent(Eval("this.shape"+Trans(i)),"mouseLeave",Thisform,"my2")
	Endfor

	Endproc

Enddefine
*
*-- EndDefine: ycont

*image button class to collapse/expand the menu and move all form controls.
Define Class yec As Image
	Picture = ""
	Height = 37
	Left = 216
	MousePointer = 15
	Top = 0
	Width = 41
	ToolTipText = "Expand/collapse"
	Name = "Image1"

	Procedure Click
	With Thisform
		Local m.delta
		m.delta=.xleft+.xwidth

		.ycl=Iif(.ycl=0,1,0)
		Do Case
		Case .ycl=1
			For i=1 To .ControlCount
				If Lower( .Controls(i).Name)=="container1"
					.Controls(i).Left=-m.delta
				Else
					.Controls(i).Left=.Controls(i).Left-m.delta
				Endi
			Endfor

		Case .ycl=0
			For i=1 To .ControlCount
				If Lower( .Controls(i).Name)=="container1"
					.Controls(i).Left=.xleft
				Else
					.Controls(i).Left=.Controls(i).Left+m.delta
				Endi
			Endfor
		Endcase
	Endwith
	Endproc

	Procedure Init
	With Thisform
		.xleft=.container1.Left
		.xwidth=.container1.Width
	Endwith
	Local m.myvar
	TEXT to m.myvar noshow
iVBORw0KGgoAAAANSUhEUgAAACkAAAAlCAIAAABQwFfaAAAAAXNSR0IArs4c6QAAAARnQU1BAACxjwv8YQUAAAAJcEhZcwAADsMAAA7DAcdvqGQAAAB+SURBVFhHY/g/cGDUbvqDwWP3y03lgbQAaYtuQG1ABih2v9xUCFVMbVC46SXUDiQwajcIvNxREwZVTVVARHzTGYzaTX8weOweLdeoDEZouVaOzWo0u+kLRu2mPxg8dtMonYfV7CCYzkfLNWqDASzXRttryGDUbvqDkWn3//8A2CIqyN0zYQIAAAAASUVORK5CYII=
	ENDTEXT
	This.PictureVal=Strconv(m.myvar,14)
	Endproc
Enddefine
*
*-- EndDefine: yec

Function yloadImg
Lparameters lcURL
Local loRequest
m.loRequest = Createobject('MsXml2.XmlHttp')
m.loRequest.Open("GET",lcURL,.F.)
m.loRequest.Send()

Return m.loRequest.ResponseBody
m.loRequest=Null
Endfunc

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



*6* created on 11 of may 2017
*this code builds a vfp editor with some interactive PEM
* a web image is set as background(can customize -can choose a disc image)
*can position the form with parameters left,top on screen (do form yeditor with xleft,xtop)
*rightclick on editbox to fire contextuel menu
*can be a standalone application (exe from a vfp project)

Publi yform
yform=Newobject("yedit")
yform.Show
Read Events
Retu
*
Define Class yedit As Form
	BorderStyle = 0
	Top = -1
	Left = 176
	Height = 528
	Width = 432
	ShowWindow = 2
	Caption = "VFP editor"
	MaxButton = .F.
	AlwaysOnTop = .T.
	Name = "Form1"

	Add Object image1 As Image With ;
		Anchor = 15, ;
		Picture = "copy_code.png", ;
		Stretch = 2, ;
		Height = 529, ;
		Left = 0, ;
		Top = 0, ;
		Width = 433, ;
		Name = "Image1"

	Add Object edit1 As EditBox With ;
		FontSize = 10, ;
		Anchor = 15, ;
		BorderStyle = 0, ;
		Height = 424, ;
		Left = 16, ;
		Top = 36, ;
		Width = 396, ;
		Name = "Edit1"

	Add Object shape1 As Shape With ;
		Top = 486, ;
		Left = 80, ;
		Height = 36, ;
		Width = 142, ;
		Anchor = 768, ;
		BackStyle = 0, ;
		BorderStyle = 0, ;
		MousePointer = 15, ;
		Name = "Shape1"

	Add Object shape2 As Shape With ;
		Top = 487, ;
		Left = 254, ;
		Height = 34, ;
		Width = 142, ;
		Anchor = 768, ;
		BackStyle = 0, ;
		BorderStyle = 0, ;
		MousePointer = 15, ;
		Name = "Shape2"

	Add Object optiongroup1 As OptionGroup With ;
		AutoSize = .T., ;
		ButtonCount = 5, ;
		BackStyle = 0, ;
		Value = 1, ;
		Height = 27, ;
		Left = 27, ;
		Top = 5, ;
		Width = 139, ;
		Name = "Optiongroup1", ;
		Option1.Caption = "", ;
		Option1.Value = 1, ;
		Option1.Height = 17, ;
		Option1.Left = 5, ;
		Option1.Style = 0, ;
		Option1.Top = 5, ;
		Option1.Width = 18, ;
		Option1.AutoSize = .T., ;
		Option1.Name = "Option1", ;
		Option2.Caption = "", ;
		Option2.Height = 17, ;
		Option2.Left = 35, ;
		Option2.Style = 0, ;
		Option2.Top = 5, ;
		Option2.Width = 18, ;
		Option2.AutoSize = .T., ;
		Option2.Name = "Option2", ;
		Option3.Caption = "", ;
		Option3.Height = 17, ;
		Option3.Left = 65, ;
		Option3.Style = 0, ;
		Option3.Top = 5, ;
		Option3.Width = 18, ;
		Option3.AutoSize = .T., ;
		Option3.Name = "Option3", ;
		Option4.Caption = "", ;
		Option4.Height = 17, ;
		Option4.Left = 89, ;
		Option4.Style = 0, ;
		Option4.Top = 5, ;
		Option4.Width = 18, ;
		Option4.AutoSize = .T., ;
		Option4.Name = "Option4", ;
		Option5.Caption = "", ;
		Option5.Height = 17, ;
		Option5.Left = 116, ;
		Option5.Style = 0, ;
		Option5.Top = 5, ;
		Option5.Width = 18, ;
		Option5.AutoSize = .T., ;
		Option5.Name = "Option5"

	Add Object spinner1 As Spinner With ;
		Height = 24, ;
		Left = 227, ;
		MousePointer = 15, ;
		SpecialEffect = 0, ;
		ToolTipText = "Fontsize", ;
		Top = 8, ;
		Width = 20, ;
		Name = "Spinner1"


	Add Object spinner2 As Spinner With ;
		Height = 24, ;
		Left = 345, ;
		MousePointer = 15, ;
		SpecialEffect = 0, ;
		ToolTipText = "Alignment", ;
		Top = 8, ;
		Width = 20, ;
		spinnerLowValue=0,;
		spinnerHighValue=2,;
		keyboardLowValue=0,;
		keyBoardHighValue=2,;
		increment=1,;
		Name = "Spinner2"

	Add Object check1 As Checkbox With ;
		Top = 12, ;
		Left = 175, ;
		Height = 17, ;
		Width = 43, ;
		AutoSize = .T., ;
		Alignment = 0, ;
		BackStyle = 0, ;
		Caption = "Bold", ;
		MousePointer = 15, ;
		Name = "Check1"


	Add Object check2 As Checkbox With ;
		Top = 12, ;
		Left = 257, ;
		Height = 17, ;
		Width = 70, ;
		AutoSize = .T., ;
		Alignment = 0, ;
		BackStyle = 0, ;
		Caption = "Readonly", ;
		MousePointer = 15, ;
		Name = "Check2"

	Procedure my1
	Lparameters nButton, nShift, nXCoord, nYCoord
*--- aevent create an array laEvents
	Aevents( myArray, 0)
*--- reference the calling object
	loObject = myArray[1]
	Local m.x
	m.x=Int(Val(Substr(loObject.Name,6)))

	With loObject
*.ToolTipText=.Name
		.DrawMode=9
		.BackStyle=1
		If m.x<=8
			.BackColor=Rgb(255,128,0)
		Else
			.BackColor=255
		Endi
		.Curvature=15
	Endwith
	Endproc

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

	Procedure Init
	Lparameters xleft,xtop
	If Empty(xleft) And Empty(xtop)
		This.AutoCenter=.T.
	Else
		This.Left=xleft
		This.Top=xtop
	Endi

this.image1.pictureval=yloadImg("http://img.over-blog-kiwi.com/1/43/54/07/20170511/ob_0506ce_copy-code.png")


	With Thisform
		For i=1 To .ControlCount
			If Lower(.Controls(i).Class)=="shape"
				Bindevent(.Controls(i),"mouseEnter",Thisform,"my1")
				Bindevent(.Controls(i),"mouseLeave",Thisform,"my2")
			Endi
		Endfor
		.ShowTips=.T.
	Endwith
	Endproc

	Procedure Destroy
	Clea Events
	Endproc

	Procedure edit1.Init
	This.Margin=15

	TEXT to this.value noshow
		Lorem ipsum dolor sit amet, consectetur adipiscing elit. Proin vel risus eget lorem feugiat
		fermentum nec a turpis. Phasellus purus sem, mollis ac posuere eget, ornare vel orci. Sed ac rutrum
		nulla. Aenean ultrices eget lectus eu efficitur. In hac habitasse platea dictumst. Nulla in iaculis nisi.
		Nullam et pulvinar tellus. Donec arcu dui, efficitur a odio non, porta congue dolor. Aenean viverra
		auctor sagittis. Integer lobortis dignissim auctor. Proin et volutpat massa.
		Cras vitae felis venenatis, egestas sem quis, sodales neque. Donec venenatis hendrerit odio, non
		pellentesque metus scelerisque ac. Suspendisse aliquet rhoncus odio id viverra. Vestibulum feugiat
		lectus a nisl pulvinar, in tempor metus eleifend. Nunc id odio quam. Praesent egestas lorem ut
		sollicitudin consectetur. Vestibulum id bibendum est. Ut vel lacus sapien. Quisque eget molestie
		sem. Integer eget purus eu orci molestie aliquam quis in ante. Integer a magna eget lectus finibus
		porttitor. Donec fringilla sapien a quam aliquet, pellentesque blandit nisl placerat. Nam hendrerit
		velit vel ex aliquam, eget convallis ante mollis.
	ENDTEXT
	Endproc

	Procedure edit1.RightClick
	Set Color Of Scheme 1 To R/w*,B+/GR+*,,,,G/GR+
	Define Popup raccourci SHORTCUT Relative From Mrow(),Mcol()  Color  Scheme 1

	Define Bar _Med_find Of raccourci Prompt "Rec\<hercher..." ;
		KEY CTRL+F, "Ctrl+F" ;
		PICTRES _Med_find ;
		MESSAGE "Recherche le texte spécifié"

	Define Bar _Med_redo Of raccourci Prompt "\<Rétablir" ;
		KEY CTRL+R, "Ctrl+R" ;
		PICTRES _Med_redo ;
		MESSAGE "Rétablit la dernière opération annulée"

	Define Bar _Med_undo Of raccourci Prompt "\<Annuler" ;
		KEY CTRL+Z, "Ctrl+Z" ;
		PICTRES _Med_undo ;
		MESSAGE "Annule la dernière modification"

	Define Bar _Med_paste Of raccourci Prompt "C\<oller" ;
		KEY CTRL+V, "Ctrl+V" ;
		PICTRES _Med_paste ;
		MESSAGE "Place le contenu du Presse-papiers au point d'insertion"

	Define Bar _Med_copy Of raccourci Prompt "Co\<pier" ;
		KEY CTRL+c, "Ctrl+C" ;
		PICTRES _Med_copy ;
		MESSAGE "Copie la sélection et la place dans le Presse-papiers"

	Define Bar _Med_cut Of raccourci Prompt "\<Couper" ;
		KEY CTRL+x, "Ctrl+X" ;
		PICTRES _Med_cut ;
		MESSAGE "Enlève la sélection et la place dans le Presse-papiers"

	Define Bar _Med_slcta Of raccourci Prompt  "Sélec\<tionner tout" ;
		KEY CTRL+A, "Ctrl+A" ;
		PICTRES _Med_slcta ;
		MESSAGE "Sélectionne tout le texte ou tous les éléments de la fenêtre active"
	Activate Popup raccourci
	Endproc

	Procedure shape1.Click
	_Cliptext=Thisform.edit1.Value
	Messagebox("Text in clipboard!",0+32+4096,'',1100)
	Endproc

	Procedure shape2.Click
	Thisform.Release
	Endproc

	Procedure optiongroup1.Init
	With This
		.SetAll("autosize",.T.,"optionbutton")
		.SetAll("backstyle",0,"optionbutton")
		.SetAll("mousepointer",15,"optionbutton")
		.AutoSize=.T.
		.SetAll("caption","","optionbutton")
		.BackStyle=0
		.Option1.ToolTipText="black"
		.Option2.ToolTipText="blue"
		.Option3.ToolTipText="red"
		.Option4.ToolTipText="maroon"
		.Option5.ToolTipText="orange"
	Endwith
	Endproc

	Procedure optiongroup1.InteractiveChange
	Do Case
	Case This.Value=1
		Thisform.edit1.ForeColor=0
	Case This.Value=2
		Thisform.edit1.ForeColor=Rgb(0,0,255)
	Case This.Value=3
		Thisform.edit1.ForeColor=255
	Case This.Value=4
		Thisform.edit1.ForeColor=Rgb(128,0,64)
	Case This.Value=5
		Thisform.edit1.ForeColor=Rgb(255,128,0)
	Endcase
	Endproc

	Procedure spinner1.UpClick
	With Thisform.edit1
		.FontSize=.FontSize+1
	Endwith
	Endproc

	Procedure spinner1.DownClick
	With Thisform.edit1
		If .FontSize>8
			.FontSize=.FontSize-1
		Endi
	Endwith
	Endproc

	Procedure spinner2.InteractiveChange
	With Thisform.edit1
		.Alignment=This.Value
		.Refresh
	Endwith
	Endproc


	Procedure check1.Click
	With Thisform.edit1
		.FontBold=!.FontBold
	Endwith
	Endproc

	Procedure check2.Click
	With Thisform.edit1
		.ReadOnly=!.ReadOnly
	Endwith
	Endproc

Enddefine
*
*-- EndDefine: yedit

function yloadImg
lparameters lcURl
	Local loRequest
	m.loRequest = Createobject('MsXml2.XmlHttp')
	m.loRequest.Open("GET",lcUrl,.F.)
	m.loRequest.Send()
	return(m.loRequest.ResponseBody	)
	m.loRequest=Null
endfunc

can make custom image as background to make some cosmetics.

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


*7* created on 31 of may 2017 .....asked by someone on UT.
*Each record of table/cursor is in a button.click on any button to see all record  data in a messagebox (can be an editbox...).
*the form is scrollable (as container).the scroolbar appears if needed.
*if the form resized the buttons are re arranged as well.

Clea All
_Screen.WindowState=1
Declare Integer Sleep In kernel32 Integer
Publi oform
oform=Newobject("ybuttons")
oform.Show
Read Events
Retu
*
Define Class ybuttons  As Form
	Top = 25
	Left = 102
	Height = 650
	Width = 862
	ShowWindow = 2
	ScrollBars = 2
	Caption = "table record in a commandbutton-click any button to see relative info"
	BackColor =0  && Rgb(212,208,210)
	Name = "form1"
	ybackcolor=0

	Procedure ybuild
	Local m.xspace,m.wbutton,m.delta,m.xleft,m.xtop
	m.xtop=20
	m.xleft=40
	m.wbutton=130
	m.delta=4  &&interspace
	m.xspace=Int(Thisform.Width-xleft)/(m.wbutton+m.delta)  &&buttons by row

	Sele ycurs
	With Thisform
		.LockScreen=.T.
		j=0
		k=0
		Scan
			i=Recno()
			Try
				.AddObject("ycont"+Trans(i),"ycont")
			Catch
			Endtry
			With Eval(".ycont"+Trans(i))
				.Width=m.wbutton
				.Height=34

				Rand(-1)
				.shape1.BackColor=Rgb(255*Rand(),255*Rand(),255*Rand())
				.shape1.MousePointer=15
				.label1.MousePointer=15
				.label1.Caption=cust_id
				j=j+1
				If j<m.xspace
					If i=1
						k=1
						.Left=m.xleft
						.Top=m.xtop
					Else
						.Left=Eval("thisform.ycont"+Trans(i-1)+".left")+Eval("thisform.ycont"+Trans(i-1)+".width")+m.delta
						.Top=m.xtop+(k-1)*(.Height+m.delta)
					Endi
				Else
					k=k+1
					.Left=m.xleft
					.Top=m.xtop+(k-1)*(.Height+m.delta)
					j=1
				Endi
				.Visible=.T.
				Try
					.Name="ycont"+Trans(i)
				Catch
				Endtry
			Endwith
			Bindevent(Eval("thisform.ycont"+Trans(i)+".label1"),"mousedown",Thisform,"my")
			Bindevent(Eval("thisform.ycont"+Trans(i)+".shape1"),"mousedown",Thisform,"my")
			Bindevent(Eval("thisform.ycont"+Trans(i)),"mouseEnter",Thisform,"my1")
			Bindevent(Eval("thisform.ycont"+Trans(i)),"mouseLeave",Thisform,"my2")

			Sleep(5)  &&to render random  backcolor as well
		Endscan
		.LockScreen=.F.
	Endwith
	Endproc

	Procedure my
	Lparameters nButton, nShift, nXCoord, nYCoord
	*--- aevent create an array laEvents
	Aevents( myArray, 0)
	*--- reference the calling object
	loObject = myArray[1]
	Local N
	N=Int(Val(Substr(loObject.Parent.Name,6)))
	Local m.myvar
	m.myvar=""
	Sele ycurs
	Go N
	m.myvar="Record:"+Trans(N)+Chr(13)
	For i=1 To Fcount()
		m.myvar=m.myvar+Field(i)+":"+Trans(Eval(Field(i)))+Chr(13)
	Endfor
	Messagebox(m.myvar,0+32+4096)
	Endproc

	Procedure Destroy
	Clea Events
	Endproc

	Procedure Load
	Close Data All
	Sele * From Home(1)+"samples\data\customer" Into Cursor ycurs
	*brow
	Endproc

	Procedure my1
	Lparameters nButton, nShift, nXCoord, nYCoord
	*--- aevent create an array laEvents
	Aevents( myArray, 0)
	*--- reference the calling object
	loObject = myArray[1]
	Thisform.ybackcolor=loObject.shape1.BackColor
	loObject.shape1.BackColor=Rgb(240,240,240)
	loObject.label1.ForeColor=255
	Endproc

	Procedure my2
	Lparameters nButton, nShift, nXCoord, nYCoord
	*--- aevent create an array laEvents
	Aevents( myArray, 0)
	*--- reference the calling object
	loObject = myArray[1]
	loObject.shape1.BackColor=Thisform.ybackcolor
	loObject.label1.ForeColor=0
	Endproc


	Procedure Init
	Thisform.Resize()
	Endproc

	Procedure Resize
	Thisform.ybuild()
	Endproc

Enddefine
*
*-- EndDefine: ybuttons

*this container below can be a simple commandbutton.

Define Class ycont As Container
	Top = 24
	Left = 24
	Width = 157
	Height = 49
	BackStyle = 0
	BorderWidth = 0
	Name = "Container1"

	Add Object shape1 As Shape With ;
		anchor=15,;
		Top = 0, ;
		Left = 0, ;
		Height = 49, ;
		Width = 157, ;
		Curvature = 15, ;
		BorderColor = Rgb(255,0,0), ;
		Name = "Shape1"

	Add Object label1 As Label With ;
		alignment=2,;
		Caption = "Label1", ;
		Height = 37, ;
		Left = 6, ;
		Top = 5, ;
		Width = 145, ;
		Name = "Label1"

	Procedure shape1.Init
	With  This
		.Left=0
		.Top=0
		.Width=.Parent.Width
		.Height=.Parent.Height
		.ZOrder(1)
		.Curvature=15
	Endwith
	Endproc

	Procedure label1.Init
	With This
		.Width=.Parent.shape1.Width-6
		.Left=(.Parent.Width-.Width)/2
		.Top=4
		.WordWrap=.T.
		.FontBold=.T.
		.ZOrder(0)
		.BackStyle=0
	Endwith
	Endproc

Enddefine
*
*-- EndDefine: ycont

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


*8*created on 01 of november 2018
*a form titlebar on demand

PUBLIC oform
oform=NEWOBJECT("yform")
oform.Show
read events

RETURN

*
DEFINE CLASS yform AS form
	BorderStyle = 0
	Height = 308
	Width = 925
	ShowWindow = 2
	AutoCenter = .T.
	Caption = "Form Titlebar on demand."
	TitleBar = 1
	BackColor = RGB(212,210,208)
	height0 = .F.
	Name = "Form1"

	ADD OBJECT shape1 AS shape WITH ;
		Top = 12, ;
		Left = 588, ;
		Height = 289, ;
		Width = 325, ;
		BorderWidth = 2, ;
		BackColor = RGB(255,255,255), ;
		Name = "Shape1"

	ADD OBJECT grid1 AS grid WITH ;
		Height = 205, ;
		Left = 24, ;
		Top = 71, ;
		Width = 540, ;
		Name = "Grid1"

	ADD OBJECT image1 AS image WITH ;
		Stretch = 2, ;
		Height = 264, ;
		Left = 601, ;
		Top = 21, ;
		Width = 300, ;
		Name = "Image1"

	ADD OBJECT label1 AS label WITH ;
		AutoSize = .T., ;
		FontSize = 11, ;
		BackStyle = 0, ;
		Caption = "MouseMove at the top of the form to make titlebar visible-MouseLeave to hide it", ;
		Height = 19, ;
		Left = 36, ;
		Top = 38, ;
		Width = 509, ;
		ForeColor = RGB(128,0,64), ;
		Name = "Label1"

	PROCEDURE Load
		_screen.windowstate=1
	ENDPROC

	PROCEDURE MouseMove
		LPARAMETERS nButton, nShift, nXCoord, nYCoord
		if between(nxcoord,0,thisform.width) and between(nycoord,0,20)
		thisform.titlebar=1
		thisform.height=thisform.height0+(sysmetric(9)+sysmetric(4))
		else
		thisform.titlebar=0
		thisform.height=thisform.height0
		endi
	ENDPROC

	PROCEDURE Init  &&internet must be connected for image1.pictureVal
	this.titlebar=0
		m.lcUrl="http://www.hotel-lagazelledor.com/assets/portail-day-2.jpg"
		try
			m.loRequest = Createobject('MsXml2.XmlHttp')
			m.loRequest.Open("GET",lcUrl,.F.)
			m.loRequest.Send()
			Thisform.image1.PictureVal=m.loRequest.ResponseBody
			m.loRequest=Null
			catch
			endtry

		thisform.height0=thisform.height
	ENDPROC

	PROCEDURE Destroy
		clea events
	ENDPROC

	PROCEDURE grid1.Init
		sele * from home(1)+"samples\data\customer" into cursor ycurs
		with this
		.recordsource="ycurs"
		.recordsourcetype=1
		.gridlines=0
		.deletemark=.f.
		.SetAll("DynamicBackColor","IIF(MOD(RECNO( ), 2)=0, RGB(100,95,155) , RGB(255,255,100))", "Column")
		locate
		endwith
	ENDPROC

ENDDEFINE
*
*-- EndDefine: yform

*Important:All Codes above are tested on VFP9SP2 & windows 10 pro and IE 11 emulation.