Easy custom ribbons

 

VFP Ribbon class is very complex and a few foxers can customize or use them in their applications (can download in https://vfpx.github.io/).
this code builds an application with clickable transparent shapes.
each shape is adjusted on the hot clickable zone to click and fires any custom code.
this shape interacts with events mouseEnter,Mouseleave and Mousedown events and use native drawmode property.
the complex ribbon class here is here just a transparent GIF image behind all the controls and offering hot areas to user clicks.i used here a web image with no disc access (pictureVal).The ribbon image can be choosed or designed by user as well.
all is inserted in a container occupying always the top of the form.
the adjustments are of course made in the vfp form designer.(dont change once set).
in the method "my" can write any user action goaled for each hot zone.i coded for demo the shapes16,17,18 and made tooltiptext on each shape as its name pour visual support only.
can move the form by mousedown on the container image or title(label).
can reduce, maximize/restore or release the form.
the form background is made with a gradient image (can customize).click to built a random one(can fix 2 colors ..)
the cover shape have 5 color styles can be changed dynamically in the optionGroup.
the ribbon background here have 5 style colors. the last can be any choosed in dialog color.
can use a pageframe with tabs (themes=.f.) to extend capabilities menus in the base container.
can add what forms,reports,dialogs,images,olecontrols,.....you want to complete this basic desktop application.

[post 233]

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

            
*1* created on sunday 14 of may 2017
*a custom easy ribbon

_screen.windowstate=1
Publi yform
yform=Newobject("yRibbon")
yform.Show
Read Events
*
Define Class yRibbon As Form
	Top = 2
	Left = 0
	Height = 392
	Width = 1018
	ShowWindow = 2
	ShowTips = .T.
	Caption = "Form1"
	KeyPreview = .T.
	TitleBar = 1
	BackColor=Rgb(217,255,255)
	yshapefill = (Rgb(0,255,0))
	Name = "form1"

	Add Object ycnt As ycont With ;
		Top = 0, ;
		Left = 0, ;
		Width = 1038, ;
		Height = 144, ;
		backstyle=1, ;
		BackColor = Rgb(255,255,0), ;
		Name = "yCnt"

	Add Object image1 As Image With ;
		Picture = "capture.png", ;
		Height = 36, ;
		Left = 0, ;
		Top = 156, ;
		Width = 84, ;
		visible=.F.
	Name = "Image1"


	Procedure my1
	Lparameters nButton, nShift, nXCoord, nYCoord
	*--- aevent create an array laEvents
	Aevents( myArray, 0)
	*--- reference the calling object
	loObject = myArray[1]
	DoDefault()
	With loObject
		.BackStyle=1
		.BackColor=Thisform.yshapefill
		.DrawMode=9
		.Curvature=5
    .tooltiptext=.name
	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 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=Int(Val(Substr(loObject.Name,6)))
	Do Case
	Case x=1  &&close button
		Nodefault
	Case x=2  &&maxmize/restore
		Nodefault
	Case x=3  &&minimize
		Nodefault
  Case x=16
  run/n notepad  &&just for demo
  case x=17
  run/n mspaint   &&just for demo
  case x=18
  run/n charmap  &&just for demo
  
	Case x=49
		Nodefault

	Otherwise
		Messagebox(loObject.Name+" clicked! write and run some code from here...",0+32+4096,'',1000)
	Endcase
	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 Load
	Declare Integer ReleaseCapture In WIN32API
	Declare Integer SendMessage In WIN32API Integer, Integer, Integer, Integer
	Endproc

	Procedure Destroy
	Clea Events
	Endproc

	Procedure KeyPress
	Lparameters nKeyCode, nShiftAltCtrl
	If nKeyCode=27
		Thisform.Release
	Endi
	Endproc

	Procedure Resize
	With This.ycnt
		.Left=0
		.Top=0
		.ZOrder(0)
	Endwith
	Endproc

	Procedure Init
	This.TitleBar=0
	This.WindowState=2
	Endproc

	Procedure image1.Init
	With This
		.Left=0
		.Top=0
		.ZOrder(1)
	Endwith
	Endproc
  
  Procedure QueryUnload
	With Thisform
		Try
			.AddObject("zshape","shape")
		Catch
		Endtry

		With .zshape
			.Left=0
			.Top=0
			.Width=.Parent.Width
			.Height=.Parent.Height
			.DrawMode=9
			.BackColor=Rgb(46,46,46)
			.ZOrder(0)
			.Visible=.T.
		Endwith
	Endwith

	If Messagebox("Want indeed to exit ?",4+64)=6
		DoDefault()
		Thisform.Release
	Else
		Thisform.RemoveObject("zshape")
		Nodefault
		Return .F.
	Endi
	Endproc



Enddefine
*
*-- EndDefine:yRibbon
**


Define Class ycont As Container
  anchor=256
	Top = 0
	Left = 0
	Width = 1038
	Height = 144
	BackColor = Rgb(255,255,0)
	Name = "yCnt"

	Add Object image1 As Image With ;
		Picture = "", ;
		BackStyle = 0, ;
		Height = 142, ;
		Left = 0, ;
		Top = 2, ;
		Width = 1024, ;
		Name = "Image1"

	Add Object shape1 As Shape With ;
		Top = 1, ;
		Left = 978, ;
		Height = 25, ;
		Width = 42, ;
		Anchor = 768, ;
		Name = "Shape1"

	Add Object shape2 As Shape With ;
		Top = 1, ;
		Left = 932, ;
		Height = 25, ;
		Width = 45, ;
		Anchor = 768, ;
		Name = "Shape2"

	Add Object shape3 As Shape With ;
		Top = 1, ;
		Left = 881, ;
		Height = 25, ;
		Width = 50, ;
		Anchor = 768, ;
		Name = "Shape3"

	Add Object shape4 As Shape With ;
		Top = 59, ;
		Left = 614, ;
		Height = 61, ;
		Width = 72, ;
		Name = "Shape4"

	Add Object shape5 As Shape With ;
		Top = 60, ;
		Left = 10, ;
		Height = 60, ;
		Width = 37, ;
		Name = "Shape5"

	Add Object shape6 As Shape With ;
		Top = 0, ;
		Left = 0, ;
		Height = 55, ;
		Width = 48, ;
		Name = "Shape6"

	Add Object shape7 As Shape With ;
		Top = 0, ;
		Left = 74, ;
		Height = 25, ;
		Width = 25, ;
		Name = "Shape7"

	Add Object shape8 As Shape With ;
		Top = 1, ;
		Left = 105, ;
		Height = 25, ;
		Width = 51, ;
		Name = "Shape8"

	Add Object shape9 As Shape With ;
		Top = 1, ;
		Left = 50, ;
		Height = 25, ;
		Width = 22, ;
		Name = "Shape9"

	Add Object label1 As Label With ;
		FontSize = 12, ;
		Anchor = 90, ;
		Alignment = 2, ;
		BackStyle = 1, ;
		Caption = "An easy  customized  Ribbon", ;
		Height = 26, ;
		Left = 156, ;
		Top = 1, ;
		Width = 730, ;
		ForeColor = Rgb(128,0,128), ;
		BackColor = Rgb(217,255,217), ;
		Name = "Label1"

	Add Object shape10 As Shape With ;
		Top = 59, ;
		Left = 688, ;
		Height = 61, ;
		Width = 72, ;
		Name = "Shape10"


	Add Object shape11 As Shape With ;
		Top = 60, ;
		Left = 757, ;
		Height = 61, ;
		Width = 94, ;
		Name = "Shape11"

	Add Object shape12 As Shape With ;
		Top = 59, ;
		Left = 852, ;
		Height = 61, ;
		Width = 60, ;
		Name = "Shape12"

	Add Object shape13 As Shape With ;
		Top = 61, ;
		Left = 267, ;
		Height = 25, ;
		Width = 21, ;
		Name = "Shape13"

	Add Object shape14 As Shape With ;
		Top = 61, ;
		Left = 289, ;
		Height = 25, ;
		Width = 24, ;
		Name = "Shape14"

	Add Object shape15 As Shape With ;
		Top = 59, ;
		Left = 318, ;
		Height = 25, ;
		Width = 21, ;
		Name = "Shape15"

	Add Object shape16 As Shape With ;
		Top = 89, ;
		Left = 86, ;
		Height = 25, ;
		Width = 21, ;
		Name = "Shape16"

	Add Object shape17 As Shape With ;
		Top = 89, ;
		Left = 108, ;
		Height = 25, ;
		Width = 21, ;
		Name = "Shape17"

	Add Object shape18 As Shape With ;
		Top = 88, ;
		Left = 132, ;
		Height = 25, ;
		Width = 36, ;
		Name = "Shape18"

	Add Object shape19 As Shape With ;
		Top = 91, ;
		Left = 275, ;
		Height = 25, ;
		Width = 33, ;
		Name = "Shape19"

	Add Object shape20 As Shape With ;
		Top = 92, ;
		Left = 311, ;
		Height = 25, ;
		Width = 30, ;
		Name = "Shape20"

	Add Object shape21 As Shape With ;
		Top = 60, ;
		Left = 352, ;
		Height = 25, ;
		Width = 31, ;
		Name = "Shape21"

	Add Object shape22 As Shape With ;
		Top = 60, ;
		Left = 384, ;
		Height = 25, ;
		Width = 34, ;
		Name = "Shape22"

	Add Object shape23 As Shape With ;
		Top = 60, ;
		Left = 417, ;
		Height = 25, ;
		Width = 36, ;
		Name = "Shape23"

	Add Object shape24 As Shape With ;
		Top = 60, ;
		Left = 456, ;
		Height = 25, ;
		Width = 21, ;
		Name = "Shape24"

	Add Object shape25 As Shape With ;
		Top = 60, ;
		Left = 480, ;
		Height = 25, ;
		Width = 21, ;
		Name = "Shape25"

	Add Object shape26 As Shape With ;
		Top = 60, ;
		Left = 504, ;
		Height = 25, ;
		Width = 21, ;
		Name = "Shape26"

	Add Object shape27 As Shape With ;
		Top = 60, ;
		Left = 527, ;
		Height = 25, ;
		Width = 21, ;
		Name = "Shape27"

	Add Object shape28 As Shape With ;
		Top = 60, ;
		Left = 552, ;
		Height = 25, ;
		Width = 21, ;
		Name = "Shape28"

	Add Object shape29 As Shape With ;
		Top = 60, ;
		Left = 578, ;
		Height = 25, ;
		Width = 21, ;
		Name = "Shape29"

	Add Object shape30 As Shape With ;
		Top = 93, ;
		Left = 353, ;
		Height = 25, ;
		Width = 21, ;
		Name = "Shape30"

	Add Object shape31 As Shape With ;
		Top = 94, ;
		Left = 376, ;
		Height = 25, ;
		Width = 21, ;
		Name = "Shape31"

	Add Object shape32 As Shape With ;
		Top = 93, ;
		Left = 398, ;
		Height = 25, ;
		Width = 21, ;
		Name = "Shape32"

	Add Object shape33 As Shape With ;
		Top = 94, ;
		Left = 420, ;
		Height = 25, ;
		Width = 34, ;
		Name = "Shape33"

	Add Object shape34 As Shape With ;
		Top = 93, ;
		Left = 455, ;
		Height = 25, ;
		Width = 36, ;
		Name = "Shape34"

	Add Object shape35 As Shape With ;
		Top = 94, ;
		Left = 491, ;
		Height = 25, ;
		Width = 37, ;
		Name = "Shape35"

	Add Object shape36 As Shape With ;
		Top = 95, ;
		Left = 531, ;
		Height = 25, ;
		Width = 33, ;
		Name = "Shape36"

	Add Object shape37 As Shape With ;
		Top = 56, ;
		Left = 922, ;
		Height = 23, ;
		Width = 86, ;
		Name = "Shape37"

	Add Object shape38 As Shape With ;
		Top = 81, ;
		Left = 920, ;
		Height = 22, ;
		Width = 86, ;
		Name = "Shape38"

	Add Object shape39 As Shape With ;
		Top = 103, ;
		Left = 920, ;
		Height = 20, ;
		Width = 100, ;
		Name = "Shape39"

	Add Object shape40 As Shape With ;
		Top = 88, ;
		Left = 168, ;
		Height = 25, ;
		Width = 24, ;
		Name = "Shape40"

	Add Object shape41 As Shape With ;
		Top = 90, ;
		Left = 192, ;
		Height = 25, ;
		Width = 24, ;
		Name = "Shape41"

	Add Object shape42 As Shape With ;
		Top = 90, ;
		Left = 217, ;
		Height = 25, ;
		Width = 24, ;
		Curvature = 0, ;
		Name = "Shape42"

	Add Object shape43 As Shape With ;
		Top = 91, ;
		Left = 241, ;
		Height = 25, ;
		Width = 34, ;
		Name = "Shape43"

	Add Object shape44 As Shape With ;
		Top = 60, ;
		Left = 84, ;
		Height = 25, ;
		Width = 120, ;
		Name = "Shape44"

	Add Object shape45 As Shape With ;
		Top = 60, ;
		Left = 204, ;
		Height = 25, ;
		Width = 60, ;
		Name = "Shape45"

	Add Object shape46 As Shape With ;
		Top = 54, ;
		Left = 54, ;
		Height = 20, ;
		Width = 22, ;
		Name = "Shape46"

	Add Object shape47 As Shape With ;
		Top = 76, ;
		Left = 53, ;
		Height = 20, ;
		Width = 24, ;
		Name = "Shape47"

	Add Object shape48 As Shape With ;
		Top = 99, ;
		Left = 52, ;
		Height = 20, ;
		Width = 24, ;
		Name = "Shape48"

	Add Object shape49 As Shape With ;
		Top = 29, ;
		Left = 997, ;
		Height = 20, ;
		Width = 24, ;
		Name = "Shape49"

	Add Object optiongroup1 As OptionGroup With ;
		AutoSize = .T., ;
		ButtonCount = 5, ;
		BackStyle = 0, ;
		Value = 1, ;
		Height = 27, ;
		Left = 683, ;
		SpecialEffect = 0, ;
		Top = 1, ;
		Width = 108, ;
		ToolTipText = "5 Style shape", ;
		Name = "Optiongroup1", ;
		Option1.Caption = "", ;
		Option1.Value = 1, ;
		Option1.Height = 17, ;
		Option1.Left = 5, ;
		Option1.Style = 0, ;
		Option1.Top = 5, ;
		Option1.Width = 18, ;
		Option1.AutoSize = .F., ;
		Option1.Name = "Option1", ;
		Option2.Caption = "", ;
		Option2.Height = 17, ;
		Option2.Left = 25, ;
		Option2.Style = 0, ;
		Option2.Top = 5, ;
		Option2.Width = 18, ;
		Option2.AutoSize = .F., ;
		Option2.Name = "Option2", ;
		Option3.Caption = "", ;
		Option3.Height = 17, ;
		Option3.Left = 45, ;
		Option3.Style = 0, ;
		Option3.Top = 5, ;
		Option3.Width = 18, ;
		Option3.AutoSize = .F., ;
		Option3.Name = "Option3", ;
		Option4.Caption = "", ;
		Option4.Height = 17, ;
		Option4.Left = 65, ;
		Option4.Style = 0, ;
		Option4.Top = 5, ;
		Option4.Width = 18, ;
		Option4.AutoSize = .F., ;
		Option4.Name = "Option4", ;
		Option5.Caption = "", ;
		Option5.Height = 17, ;
		Option5.Left = 85, ;
		Option5.Style = 0, ;
		Option5.Top = 5, ;
		Option5.Width = 18, ;
		Option5.AutoSize = .F., ;
		Option5.Name = "Option5"

	Add Object command1 As CommandButton With ;
		AutoSize = .T., ;
		Top = 2, ;
		Left = 793, ;
		Height = 25, ;
		Width = 90, ;
		FontBold = .T., ;
		FontSize = 8, ;
		Anchor = 768, ;
		Caption = "G..backColor", ;
		MousePointer = 15, ;
		ToolTipText = "Random background gradient img", ;
		SpecialEffect = 2, ;
		BackColor = Rgb(128,255,0), ;
		Name = "Command1"

	Add Object optiongroup2 As OptionGroup With ;
		AutoSize = .T., ;
		ButtonCount = 5, ;
		BackStyle = 0, ;
		Value = 1, ;
		Height = 27, ;
		Left = 163, ;
		SpecialEffect = 0, ;
		Top = 0, ;
		Width = 103, ;
		ToolTipText = "4 Style  backColor", ;
		Name = "Optiongroup2", ;
		Option1.Caption = "", ;
		Option1.Value = 1, ;
		Option1.Height = 17, ;
		Option1.Left = 5, ;
		Option1.Style = 0, ;
		Option1.Top = 5, ;
		Option1.Width = 18, ;
		Option1.AutoSize = .F., ;
		Option1.Name = "Option1", ;
		Option2.Caption = "", ;
		Option2.Height = 17, ;
		Option2.Left = 25, ;
		Option2.Style = 0, ;
		Option2.Top = 5, ;
		Option2.Width = 18, ;
		Option2.AutoSize = .F., ;
		Option2.Name = "Option2", ;
		Option3.Caption = "", ;
		Option3.Height = 17, ;
		Option3.Left = 45, ;
		Option3.Style = 0, ;
		Option3.Top = 5, ;
		Option3.Width = 18, ;
		Option3.AutoSize = .F., ;
		Option3.Name = "Option3", ;
		Option4.Caption = "", ;
		Option4.Height = 17, ;
		Option4.Left = 63, ;
		Option4.Top = 5, ;
		Option4.Width = 18, ;
		Option4.AutoSize = .T., ;
		Option4.Name = "Option4", ;
		Option5.Caption = "", ;
		Option5.Height = 17, ;
		Option5.Left = 80, ;
		Option5.Top = 5, ;
		Option5.Width = 18, ;
		Option5.AutoSize = .T., ;
		Option5.Name = "Option5"

	Add Object combo1 As ComboBox With ;
		Height = 25, ;
		Left = 264, ;
		Top = 1, ;
		Width = 20, ;
		Name = "Combo1"

	Procedure Init
	With This
		.Parent.yshapefill=255
		.Left=0
		.Top=0
		.SetAll("mousepointer",15,"shape")
		.SetAll("backstyle"  ,0,"shape")
		.SetAll("borderstyle",0,"shape")
		.optiongroup2.Value=1
		.optiongroup2.InteractiveChange()
		For i=1 To .ControlCount
			If Lower(.Controls(i).Class)=="shape"
				Bindevent(.Controls(i),"mouseEnter",Thisform,"my1")
				Bindevent(.Controls(i),"mouseLeave",Thisform,"my2")
				Bindevent(.Controls(i),"mouseDOWN",Thisform,"my")
			Endi
		Endfor
   .image1.PictureVal=yloadImg("http://img.over-blog-kiwi.com/1/43/54/07/20170514/ob_0ab497_zback.gif")
	Endwith
	Endproc

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



	Procedure shape1.Click
	*Thisform.Release
  Thisform.QueryUnload()      &&release or not
  endproc
  
	Procedure shape2.Click
	Thisform.WindowState=Iif(Thisform.WindowState=0,2,0)
	Endproc

	Procedure shape3.Click
	Thisform.WindowState=1
	Endproc

	Procedure label1.MouseDown
	Lparameters nButton, nShift, nXCoord, nYCoord
	This.Parent.image1.MouseDown(1)
	Endproc

	Procedure shape49.Click
	Local m.myvar
	TEXT to m.myvar pretext 7 noshow
		this code builds an application with clickable transparent shapes.
		each shape is adjusted on the hot clickable zone to click and fires any custom code.
		this shape interacts with events mouseEnter,Mouseleave and Mousedown events and use native drawmode property.
		the complex ribbon class here is here just a transparent GIF image behind all the controls and offering hot
		areas to user clicks.
		all is inserted in a container occupying always the top of the form.
		the adjustments are of course made in the vfp form designer.(dont change once set).
		in the method "my" can write any user action goaled for each hot zone.
		can move the form by mousedown on the container image or title(label).
		can reduce, maximize/restore or release the form.
		the form background is made with a gradient image (can customize).click to built a random one(can fix 2 colors ..)
		the cover shape have 5 color styles can be changed dynamically in the optionGroup.
		the ribbon background here have 5 style colors. the last can be any choosed in dialog color.its indeed teh form backcolor shown with gif image transparency !
		can use a pageframe with tabs (themes=.f.) to extend capabilities menus in the base container.
		can add what forms,reports,dialogs,images,olecontrols,.....you want to complete this basic desktop application.
	ENDTEXT
	Local oshell
	oshell = Createobject('WScript.Shell')
	oshell.Popup(m.myvar,0, 'summary help', 0+32+4096)  &&4,16,48,64...
	oshell=Null
	Endproc

	Procedure optiongroup1.Init
	With This
		.BackStyle=0
		.AutoSize=.T.
		.SetAll("mousepointer",15,"Optionbutton")
		.ZOrder(0)
		.Value=1
	Endwith
	Endproc

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

	Procedure command1.Click
	*create horizontal bmp image   with linear gradient 2 colors
	Local nWidth,lnHeight As Integer
	Set Classlib To Locfile (Home(1)+"ffc\_gdiplus.vcx")
	Local    OBitmap, oGraphics, Open, nY,nX, cFileName
	*hoprizontal
	lnWidth= Thisform.Width
	lnHeight= Thisform.Height
	m.cFileName =Addbs(Sys(2023))+"ygrad_"+Sys(2015)+".jpg"

	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/jpeg")
	*can be mimes as  image/bmp,image/png,image/gif....
	* 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
	Erase ( m.cFileName)   && can not erase and use it saved as it
	Endproc

	Procedure optiongroup2.Init
	With This
		.BackStyle=0
		.AutoSize=.T.
		.SetAll("mousepointer",15,"Optionbutton")
		.ZOrder(0)
		.Value=1
	Endwith
	Endproc

	Procedure optiongroup2.InteractiveChange
	With  Thisform.ycnt
		.BackStyle=1
		Do Case
		Case This.Value=1
			.BackColor=Rgb(193,217,241)
		Case This.Value=2
			.BackColor=Rgb(255,255,0)
		Case This.Value=3
			.BackColor=Rgb(0,255,140)
		Case This.Value=4
			.BackColor=Rgb(217,255,255)
		Case This.Value=5
			Local m.xcolor
			m.xcolor=Getcolor()
			If m.xcolor=-1
				Return .F.
			Endi
			.BackColor=m.xcolor
		Endcase
		.Refresh
	Endwith
	Endproc

	Procedure combo1.Click
	Do Case
	Case This.Value=1
		This.Parent.BackColor=Rgb(172,172,146)
	Case This.Value=2
		This.Parent.BackColor=Rgb(223,229,229)
	Case This.Value=3
		This.Parent.BackColor=Rgb(233,238,238)
	Case This.Value=4
		This.Parent.BackColor=Rgb(217,255,255)
	Endcase
	Endproc

	Procedure combo1.Init
	With This
		.AddItem("black1")
		.AddItem("black2")
		.AddItem("silver")
		.AddItem("office")
		.ListIndex=1
		.Style=2
		.Value=1
	Endwith
	Endproc

Enddefine
*
*-- EndDefine: ycont

Function yloadImg
Lparameters lcURL
Local loRequest
m.loRequest = Createobject('MsXml2.XmlHttp')
m.loRequest.Open("GET",lcURL,.F.)
m.loRequest.Send()
local m.x
m.x=m.loRequest.ResponseBody
m.loRequest=Null
Return m.x
Endfunc

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

*2* created on sunday 14 of may  2017
*this code builds a special contextuel  menu with containers.
*a main container is built with some menus item as containers classes.
*the main container is drawn to be visible or invisible and have ncount  items (menu item).no subItem at this time.
*each menu item have  label, an icon and a background image responding to events mouseEnter,MouseLeave and mouseDown.
*bindevent is used.
*the code is shipped with 3 encoded background images.(_screen.pict1 and _screen.pict2  and _screen.pict3
*and use pictureVal image control property)
*can customize in code :
      *background color of main container
      *background image of items (can use picture instead pictureVal)
      *icon
      *label
      *and actions to code in 'my' method
      
      
set defa to addbs(justpath(sys(16,1)))
local m.ydownl
m.ydownl=.t.  && make it false since images downloaded
if m.ydownl=.t.
*download some pngs used in code (8)
*the code downloads first working image from my blog (or point later on the form to any image on disc)
Declare Integer Sleep In kernel32 Integer
Declare Integer URLDownloadToFile In urlmon.Dll Integer pCaller, String szURL, String szFileName, Integer dwReserved, Integer lpfnCB
Declare Integer DeleteUrlCacheEntry In wininet String lpszUrlName

for i=1 to 8
do case
case i=1
lcDownloadURL = "http://img.over-blog-kiwi.com/1/43/54/07/20170514/ob_0bed52_edit-find-32.png"
lcDownloadLoc ="Edit_find_32.png"
case i=2
lcDownloadURL = "http://img.over-blog-kiwi.com/1/43/54/07/20170514/ob_1c2728_edit-paste-32.png"
lcDownloadLoc ="Edit_paste_32.png"
case i=3
lcDownloadURL = "http://img.over-blog-kiwi.com/1/43/54/07/20170514/ob_5a11af_file-open-32.png"
lcDownloadLoc ="File_open_32.png"
case i=4
lcDownloadURL = "http://img.over-blog-kiwi.com/1/43/54/07/20170514/ob_bbd04f_file-print-32.png"
lcDownloadLoc ="File_Print_32.png"
case i=5
lcDownloadURL = "http://img.over-blog-kiwi.com/1/43/54/07/20170514/ob_54538a_file-printpreview-32.png"
lcDownloadLoc ="File_printPreview_32.png"
case i=6
lcDownloadURL = "http://img.over-blog-kiwi.com/1/43/54/07/20170514/ob_c69ec7_file-save-32.png"
lcDownloadLoc ="File_save_32.png"
case i=7
lcDownloadURL = "http://img.over-blog-kiwi.com/1/43/54/07/20170514/ob_0313af_file-saveas-32.png"
lcDownloadLoc ="File_saveAs_32.png"
case i=8
lcDownloadURL = "http://img.over-blog-kiwi.com/1/43/54/07/20170514/ob_959fc0_ymen.png"
lcDownloadLoc ="ymen.png"
endcase

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

publi yform
yform=newObject("asup")
yform.show
read events
retu
*
DEFINE CLASS asup AS form
   showWindow=2
   autocenter=.t.
	Top = 0
	Left = 0
	Height =380
	Width = 432
	Caption = "A special contextuel menu"
	Name = "form1"
	
	ADD OBJECT optionGroup1 AS optiongroup with ;
	AutoSize = .T.,;
	ButtonCount = 3,;
	Value = 1,;
	Height = 27,;
	Left = 144,;
	Top = 5,;
	Width = 197,;
	Name = "Optiongroup1",;
	Option1.Caption = "",;
	Option1.Value = 1,;
	Option1.Height = 17,;
	Option1.Left = 5,;
	Option1.Style = 0,;
	Option1.Top = 5,;
	Option1.Width = 61,;
	Option1.AutoSize = .T.,;
	Option1.Name = "Option1",;
	Option2.Caption = "",;
	Option2.Height = 17,;
	Option2.Left = 68-40,;
	Option2.Style = 0,;
	Option2.Top = 5,;
	Option2.Width = 61,;
	Option2.AutoSize = .T.,;
	Option2.Name = "Option2",;
	Option3.Caption = "",;
	Option3.Height = 17,;
	Option3.Left = 131-80,;
	Option3.Style = 0,;
	Option3.Top = 5,;
	Option3.Width = 61,;
	Option3.AutoSize = .T.,;
	Option3.Name = "Option3"

	ADD OBJECT shape1 AS  shape  WITH ;
		Height = 27, ;
		Left = 350, ;
		Top = 5, ;
		Width = 40, ;
		mousepointer=15,;
		curvature=15,;
		backcolor=rgb(255,255,0),;
		Name = "shape1"
	
	ADD OBJECT image1 AS image WITH ;
		Picture = "ymen.png", ;
		Height = 27, ;
		Left = 24, ;
		Top = 24, ;
		Width = 79, ;
		Name = "Image1"

 ADD OBject ycont AS Container with ;
 visible=.f., ;
 name="ycont"

 procedure shape1.click
 local m.xcolor
 m.xcolor=getcolor()
 if m.xcolor=-1
 return .f.
 endi
 this.backcolor=m.xcolor
 thisform.ycont.backcolor=this.backcolor
 thisform.ycont.visible=.t.
 endproc

	PROCEDURE image1.Click
thisform.ycont.visible=iif(thisform.ycont.visible=.f.,.t.,.f.)
	endproc
	
	procedure init	
		with thisform.ycont
		.left=thisform.image1.left+thisform.image1.width/2
		.top=thisform.image1.top+thisform.image1.height+1
		.backcolor=thisform.shape1.backcolor        &&rgb(0,255,255)   &&rgb(128,128,128)
  .addobject("yclo","image")
		with .yclo
		.Anchor=768
		.width=10
		.height=10
		.left=.parent.width-12
		.top=.parent.height-14
		.stretch=2		
		.mousepointer=15
		.picture=""
		.zorder(0)
		.visible=.t.
		endwith
				
		.visible=.f.
		endwith

		local m.nHeight,ncount
		m.ncount=7   &&7 menus items here(containers)
		
		for i=1 to m.ncount
		thisform.ycont.addobject("ycnt"+trans(i),"yitem")
		
		with eval('thisform.ycont.ycnt'+trans(i))
		.borderwidth=0
		.backstyle=0
		.left=10
		if i=1
		.top=(i-1)*.height+1
		else
		.top=eval("thisform.ycont.ycnt"+trans(i-1)+".top")+eval("thisform.ycont.ycnt"+trans(i-1)+".height")+1
		if i=m.ncount
		m.nheight=.top+.height+14
		m.nwidth=.width+10
		endi
		endi
		
		do case
		case i=1
		.image1.picture="File_Print_32.png"
		.label1.caption="This is Item"+trans(i)
		
		 case i=2
		.image1.picture="Edit_Paste_32.png"
		.label1.caption="This is Item"+trans(i)

		case i=3
		.image1.picture="Edit_Find_32.png"
		.label1.caption="This is Item"+trans(i)

		case i=4
		.image1.picture="File_Open_32.png"
		.label1.caption="This is Item"+trans(i)

		case i=5
		.image1.picture="File_Save_32.png"
		.label1.caption="This is Item"+trans(i)
		
		case i=6
		.image1.picture="File_PrintPreview_32.png"
		.label1.caption="This is Item"+trans(i)
		
		case i=7
		.image1.picture="File_SaveAs_32.png"
		.label1.caption="This is Item"+trans(i)
		endcase
		.zorder(0)
		.visible=.t.
		.refresh
		endwith
		
		bindevent(eval('thisform.ycont.ycnt'+trans(i)),"mousedown",thisform,"my")
		bindevent(eval('thisform.ycont.ycnt'+trans(i)+".label1"),"mousedown",thisform,"my")
		bindevent(eval('thisform.ycont.ycnt'+trans(i)+".image1"),"mousedown",thisform,"my")
		bindevent(eval('thisform.ycont.ycnt'+trans(i)+".yimg"),"mousedown",thisform,"my")
		bindevent(thisform.ycont.yclo,"mousedown",thisform,"my1")
		endfor
	
		with thisform.ycont
		.backstyle=1
		.borderwidth=1
		.width =m.nWidth
		.height=m.nHeight+14
		.yclo.width=10
		.yclo.height=10
		.yclo.top=m.nheight-5
		.yclo.left=m.nwidth-14
		.yclo.visible=.t.
		.refresh
		endwith

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

    local m.x
    m.x=int(val(substr(loObject.parent.name,5)))
    *code actions here
    do case
    case m.x=1
    *.....
    case m.x=2
    *.....
    case m.x=3
    *.....
    case m.x=4
    *.....
    case m.x=5
    *.....
    case m.x=6
    *.....
    case m.x=7
    *.....
    endcase
	endproc

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

  procedure destroy
  _screen.pict1=null
  release _screen.pict1
  _screen.pict2=null
  release _screen.pict2
  clea events
  endproc
ENDDEFINE
*
*-- EndDefine: asup

DEFINE CLASS yitem AS container
	Top = 10
	Left = 9
	Width = 168
	Height = 38
	BackStyle = 0
	BorderWidth = 0
	Name = "yitem"
	
	ADD OBJECT yimg AS image WITH ;
		Picture = "", ;
		Height = 32, ;
		Left = 3, ;
		Top = 5, ;
		Width = 32, ;
		visible=.f.,;
		Name = "yimg"

	ADD OBJECT image1 AS image WITH ;
		Picture = "edit_find_32.png", ;
		Height = 32, ;
		Left = 3, ;
		MousePointer = 15, ;
		Top = 5, ;
		Width = 32, ;
		Name = "Image1"

	ADD OBJECT label1 AS label WITH ;
		AutoSize = .T., ;
		FontBold = .T., ;
		FontSize = 10, ;
		BackStyle = 0, ;
		Caption = "This is item menu ", ;
		Height = 18, ;
		Left = 49, ;
		MousePointer = 15, ;
		Top = 12, ;
		Width = 118, ;
		Name = "Label1"

	PROCEDURE MouseEnter
		LPARAMETERS nButton, nShift, nXCoord, nYCoord
		with this	
		with .yimg
		     .stretch=2
		     .anchor=15
		     .left=3
		     .top=3
		     .width=.parent.width-6
		     .height=.parent.height-6
         .pictureVal=eval("_screen.pict"+trans(thisform.optionGroup1.value) )  && 1,2,3 even dynamically
		     .zorder(1)		
		     .visible=.t.
		endwith
		.borderwidth=0
		.label1.forecolor=255
		.left=.left-2
		.top=.top-2
		endwith
	ENDPROC

	PROCEDURE MouseLeave
		LPARAMETERS nButton, nShift, nXCoord, nYCoord
		with this
		.borderwidth=0
		.label1.forecolor=0
		.yimg.visible=.f.
		.left=.left+2
		.top=.top+2
		endwith
	ENDPROC
	
	procedure init
	local m.myvar1,m.myvar2,m.myvar3
	text to m.myvar1 noshow
	iVBORw0KGgoAAAANSUhEUgAAAOcAAAA4CAYAAAAGnO/aAAAAAXNSR0IArs4c6QAAAARnQU1BAACxjwv8YQUAAAAJcEhZcwAADsMAAA7DAcdvqGQAAAM8SURBVHhe7dP5a88BHMfxJSUlWmbMmDFjNuOb0kqYMdZYY4455phjfPuyxow5ho1vmzVmzDHWtJa13FqrtazlypHScuTKkZIcuXKkla9avF8ffwI9f3j8CQ+/DD8/n9vB45DZQbI6SnYnyeksuV1kY1fJ85dtAVIQKN4gKQyW4hApCZXSMCkLl/IIORApFdFS6ZKqEVI9UmpipHaU1I2WE7FyKk7Oxkt9gjQkSmOSNCVLc4q0zJCLqR3M5TkdzdW0Tub6gs7mZnoXc2tpN9Oa4W/uuAPMPU+geZAZZB5lBZsn2SHmWU6oeZEbZl5uGmRe5UWYN9uizLuCaPPB6zKfCkeYL8UjzbeSGPOjdJRpKxttfpbHGt/B8VIRL5UJUpUo1UlSkyy1KVI3Q06kyum5cjZN6hdKQ7o0LpWmDGl2S4unHTnJSU5ykpOc5CQnOcn5BznJSU5ykpOc5CQnOclJTnKSk5zkJCc5yUlOcpKTnOQkJznJSU5ykpOc5CQnOX+nJCc5yUlOcpKTnOQkJznJSU5ykpOc5CQnOclJTnKSk5zkJCc5yUlOcpKTnOQkJznJSU5ykpOc5CQnOclJTnKSk5zkJCc5yUlOcv7zObPHdPfljJXcWNk4LsBsjpMtEyQ/vofZPlG8kwJNUYIUJ0rJ5J5m9xQpS5J9yb3M/qlyaFqQOZwildPl6MzepnqW1KTKsdnBpm6uHJ/Xx5xMkzPz5dyCvqZ+kTSkh5jGxdK0RM4v62daMuTCcrm0ItRcccs1T39zY6XcXCW3MgeY1iy5vVrurgkz97Pl4dqB5vE6ebpenueGmxcb5K+cm+V1nrzdMti83yof8+VzQYT5ul2+7xhifnilrVB+FkUa306HYoeSKNnlsHuolDrscdgbLfscyh32D5ODDoeGS4XDYYcjrnbkJCc5yUlOcpKTnOQkJznJSU5ykpOc5CQnOclJTnKSk5zkJCc5yUlOcpKTnOQkJznJSU5ykpOc5CQnOclJTnKSk5zkJOdv5CQnOclJTnKSk5zkJCc5yUlOcpKTnOQkJznJSU5ykpOc5CQnOclJTnKSk5zkJCc5yUlOcpKTnOQkJznJSU5y/h85Xb5fEp0nsnymgZ4AAAAASUVORK5CYII=
		endtext	
		
	text to m.myvar2 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	

    text to m.myvar3 noshow
    iVBORw0KGgoAAAANSUhEUgAAAJYAAAAnCAYAAADtl7EyAAAAAXNSR0IArs4c6QAAAARnQU1BAACxjwv8YQUAAAAJcEhZcwAADsMAAA7DAcdvqGQAAAGdSURBVHhe7dLJURQAAERR80/CFVmCQEWFiMbrUCX1sdv6NcCc+/AyeO9uHv4cn93/c32GK/x+m8tTfrmvb/XzyYU6nPQl3b3e51N+uE/n+H44fjzDh/99e533L7k9HBfrLw+FxWqaKS0WPBQWq2mmtFjwUFisppnSYsFDYbGaZkqLBQ+FxWqaKS0WPBQWq2mmtFjwUFisppnSYsFDYbGaZkqLBQ+FxWqaKS0WPBQWq2mmtFjwUFisppnSYsFDYbGaZkqLBQ+FxWqaKS0WPBQWq2mmtFjwUFisppnSYsFDYbGaZkqLBQ+FxWqaKS0WPBQWq2mmtFjwUFisppnSYsFDYbGaZkqLBQ+FxWqaKS0WPBQWq2mmtFjwUFisppnSYsFDYbGaZkqLBQ+FxWqaKS0WPBQWq2mmtFjwUFisppnSYsFDYbGaZkqLBQ+FxWqaKS0WPBQWq2mmtFjwUFisppnSYsFDYbGaZkqLBQ+FxWqaKS0WPBQWq2mmtFjwUFisppnSYsFDYbGaZkqLBQ+FxWqaKS0WPBQWq2mmdHs4PgJrt7p7uY6r+wAAAABJRU5ErkJggg==
    endtext

with _screen
.addproperty("pict1",strconv(m.myvar1,14))
.addproperty("pict2",strconv(m.myvar2,14))
.addproperty("pict3",strconv(m.myvar3,14))
endwith
   endproc

ENDDEFINE
*
*-- EndDefine: yitem

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

*3* created on sunday 14 of may 2017
*this code builds another special contextuel menu with containers
*a main container is built with some menus item as containers classes.
*the main container is drawn to be visible or invisible and have ncount  items (menu item).no suItem at this time.
*each menu item have  label, an icon nd a background image responding to events mouseEnter,MouseLeave and mouseDown.
*bindevent is used.
*the code is shipped with 3 encoded background images.(_screen.pict1 and _screen.pict2  and _screen.pict3
*and use pictureVal image control property)
*can customize in code :
*background color of main container
*background image of items (can use picture instead pictureVal)
*icon
*label
*and actions to code in 'my' method



Set Defa To Addbs(Justpath(Sys(16,1)))
Local m.ydownl
m.ydownl=.T.  && make it false since images downloaded
If m.ydownl=.T. 
	*download some pngs used in code (8)
	*the code downloads first working image from my blog (or point later on the form to any image on disc)
	Declare Integer Sleep In kernel32 Integer
	Declare Integer URLDownloadToFile In urlmon.Dll Integer pCaller, String szURL, String szFileName, Integer dwReserved, Integer lpfnCB
	Declare Integer DeleteUrlCacheEntry In wininet String lpszUrlName

	For i=1 To 8
		Do Case
		Case i=1
			lcDownloadURL = "http://img.over-blog-kiwi.com/1/43/54/07/20170514/ob_0bed52_edit-find-32.png"
			lcDownloadLoc ="Edit_find_32.png"
		Case i=2
			lcDownloadURL = "http://img.over-blog-kiwi.com/1/43/54/07/20170514/ob_1c2728_edit-paste-32.png"
			lcDownloadLoc ="Edit_paste_32.png"
		Case i=3
			lcDownloadURL = "http://img.over-blog-kiwi.com/1/43/54/07/20170514/ob_5a11af_file-open-32.png"
			lcDownloadLoc ="File_open_32.png"
		Case i=4
			lcDownloadURL = "http://img.over-blog-kiwi.com/1/43/54/07/20170514/ob_bbd04f_file-print-32.png"
			lcDownloadLoc ="File_Print_32.png"
		Case i=5
			lcDownloadURL = "http://img.over-blog-kiwi.com/1/43/54/07/20170514/ob_54538a_file-printpreview-32.png"
			lcDownloadLoc ="File_printPreview_32.png"
		Case i=6
			lcDownloadURL = "http://img.over-blog-kiwi.com/1/43/54/07/20170514/ob_c69ec7_file-save-32.png"
			lcDownloadLoc ="File_save_32.png"
		Case i=7
			lcDownloadURL = "http://img.over-blog-kiwi.com/1/43/54/07/20170514/ob_0313af_file-saveas-32.png"
			lcDownloadLoc ="File_saveAs_32.png"
		Case i=8
			lcDownloadURL = "http://img.over-blog-kiwi.com/1/43/54/07/20170514/ob_959fc0_ymen.png"
			lcDownloadLoc ="ymen.png"
		Endcase

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

Publi yform
yform=Newobject("asup")
yform.Show
Read Events
Retu
*
Define Class asup As Form
	ShowWindow=2
	AutoCenter=.T.
	Top = 0
	Left = 0
	Height =380
	Width = 432
	Caption = "Form1"
	Name = "form1"

	Add Object optionGroup1 As OptionGroup With ;
		AutoSize = .T.,;
		ButtonCount = 3,;
		Value = 1,;
		Height = 27,;
		Left = 144,;
		Top = 5,;
		Width = 197,;
		Name = "Optiongroup1",;
		Option1.Caption = "",;
		Option1.Value = 1,;
		Option1.Height = 17,;
		Option1.Left = 5,;
		Option1.Style = 0,;
		Option1.Top = 5,;
		Option1.Width = 61,;
		Option1.AutoSize = .T.,;
		Option1.Name = "Option1",;
		Option2.Caption = "",;
		Option2.Height = 17,;
		Option2.Left = 68-40,;
		Option2.Style = 0,;
		Option2.Top = 5,;
		Option2.Width = 61,;
		Option2.AutoSize = .T.,;
		Option2.Name = "Option2",;
		Option3.Caption = "",;
		Option3.Height = 17,;
		Option3.Left = 131-80,;
		Option3.Style = 0,;
		Option3.Top = 5,;
		Option3.Width = 61,;
		Option3.AutoSize = .T.,;
		Option3.Name = "Option3"


	Add Object image1 As Image With ;
		Picture = "ymen.png", ;
		Height = 27, ;
		Left = 24, ;
		Top = 24, ;
		Width = 79, ;
		Name = "Image1"

	Add Object ycont As Container With ;
		visible=.F., ;
		name="ycont"

	Procedure optionGroup1.InteractiveChange
	With Thisform.ycont
		For i=1 To .ControlCount
			Try
				.Controls(i).MouseLeave(1)
			Catch
			Endtry
		Endfor
		.Refresh
	Endwith
	Endproc

	Procedure image1.Click
	Thisform.ycont.Visible=Iif(Thisform.ycont.Visible=.F.,.T.,.F.)
	Endproc

	Procedure Init
	With Thisform.ycont
		.Left=Thisform.image1.Left+Thisform.image1.Width/2
		.Top=Thisform.image1.Top+Thisform.image1.Height +1
		*.backcolor=thisform.shape1.backcolor        &&rgb(0,255,255)   &&rgb(128,128,128)
		.BackStyle=0
		.AddObject("yclo","image")
		With .yclo
			.Anchor=768
			.Width=10
			.Height=10
			.Left=.Parent.Width-12
			.Top=.Parent.Height-14
			.Stretch=2
			.MousePointer=15
			.Picture=""
			.ZOrder(0)
			.Visible=.T.
		Endwith
		.Visible=.F.
	Endwith

	Local m.nHeight,ncount
	m.ncount=7   &&7 menus items here(containers)
	For i=1 To m.ncount
		Thisform.ycont.AddObject("ycnt"+Trans(i),"yitem")

		With Eval('thisform.ycont.ycnt'+Trans(i))
			.BorderWidth=0
			.BackStyle=0
			.Left=10
			If i=1
				.Top=0   &&+1
			Else
				.Top=Eval("thisform.ycont.ycnt"+Trans(i-1)+".top")+Eval("thisform.ycont.ycnt"+Trans(i-1)+".height")  &&+1
				If i=m.ncount
					m.nHeight=.Top+.Height+14
					m.nwidth=.Width+10
				Endi
			Endi

			Do Case
			Case i=1
				.image1.Picture="File_Print_32.png"
				.label1.Caption="This is Item"+Trans(i)

			Case i=2
				.image1.Picture="Edit_Paste_32.png"
				.label1.Caption="This is Item"+Trans(i)

			Case i=3
				.image1.Picture="Edit_Find_32.png"
				.label1.Caption="This is Item"+Trans(i)

			Case i=4
				.image1.Picture="File_Open_32.png"
				.label1.Caption="This is Item"+Trans(i)

			Case i=5
				.image1.Picture="File_Save_32.png"
				.label1.Caption="This is Item"+Trans(i)

			Case i=6
				.image1.Picture="File_PrintPreview_32.png"
				.label1.Caption="This is Item"+Trans(i)

			Case i=7
				.image1.Picture="File_SaveAs_32.png"
				.label1.Caption="This is Item"+Trans(i)

			Endcase
			.ZOrder(0)
			.Visible=.T.
			.Refresh
		Endwith

		Bindevent(Eval('thisform.ycont.ycnt'+Trans(i)),"mousedown",Thisform,"my")
		Bindevent(Eval('thisform.ycont.ycnt'+Trans(i)+".label1"),"mousedown",Thisform,"my")
		Bindevent(Eval('thisform.ycont.ycnt'+Trans(i)+".image1"),"mousedown",Thisform,"my")
		Bindevent(Eval('thisform.ycont.ycnt'+Trans(i)+".yimg"),"mousedown",Thisform,"my")
		Bindevent(Thisform.ycont.yclo,"mousedown",Thisform,"my1")
	Endfor

	With Thisform.ycont
		.BackStyle=0   &&1
		.BorderWidth=1
		.Width =m.nwidth
		.Height=m.nHeight+14
		.yclo.Width=10
		.yclo.Height=10
		.yclo.Top=m.nHeight-5
		.yclo.Left=m.nwidth-14
		.yclo.Visible=.T.
		.Refresh
	Endwith
	Endproc

	Procedure my
	Lparameters nButton, nShift, nXCoord, nYCoord
	*--- aevent create an array laEvents
	Aevents( myArray, 0)
	*--- reference the calling object
	loObject = myArray[1]
	Messagebox(loObject.Parent.Name +" clicked.....do some code from here",0+32+4096,"",1100)

	Local m.x
	m.x=Int(Val(Substr(loObject.Parent.Name,5)))
	Do Case
	Case m.x=1
		*.....
	Case m.x=2
		*.....
	Case m.x=3
		*.....
	Case m.x=4
		*.....
	Case m.x=5
		*.....
	Case m.x=6
		*.....
	Case m.x=7
		*.....
	Endcase
	Endproc

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

	Procedure Destroy
	_Screen.pict1=Null
	Release _Screen.pict1
	_Screen.pict2=Null
	Release _Screen.pict2
	Clea Events
	Endproc

Enddefine
*
*-- EndDefine: asup

Define Class yitem As Container
	Top = 10
	Left = 9
	Width = 168
	Height = 38
	BackStyle = 0
	BorderWidth = 0
	Name = "yitem"

	Add Object yimg As Image With ;
		Picture = "", ;
		Height = 32, ;
		Left = 3, ;
		Top = 5, ;
		Width = 32, ;
		visible=.F.,;
		Name = "yimg"

	Add Object image1 As Image With ;
		Picture = "edit_find_32.png", ;
		Height = 32, ;
		Left = 3, ;
		MousePointer = 15, ;
		Top = 5, ;
		Width = 32, ;
		Name = "Image1"

	Add Object label1 As Label With ;
		AutoSize = .T., ;
		FontBold = .T., ;
		FontSize = 10, ;
		BackStyle = 0, ;
		Caption = "This is item menu ", ;
		Height = 18, ;
		Left = 49, ;
		MousePointer = 15, ;
		Top = 12, ;
		Width = 118, ;
		Name = "Label1"

	Procedure MouseEnter
	Lparameters nButton, nShift, nXCoord, nYCoord
	With This
		With .yimg
			.Stretch=2
			.Anchor=15
			.Left=3
			.Top=0  &&
			.Width=.Parent.Width-6
			.Height=.Parent.Height
			.PictureVal=Eval("_screen.pict"+Trans(Thisform.optionGroup1.Value) )  && 1,2,3 even dynamically
			.ZOrder(1)
			.Visible=.T.
		Endwith
		.BorderWidth=0
		.label1.ForeColor=255
		.yimg.PictureVal=_Screen.pict4    
	Endwith
	Endproc
	Procedure MouseLeave
	Lparameters nButton, nShift, nXCoord, nYCoord
	With This
		.BorderWidth=0
		.label1.ForeColor=0
		.yimg.PictureVal=Eval("_screen.pict"+Trans(Thisform.optionGroup1.Value) )
	Endwith
	Endproc
  
	Procedure Init
	Local m.myvar1,m.myvar2,m.myvar3,m.myvar4
	TEXT to m.myvar1 noshow
	iVBORw0KGgoAAAANSUhEUgAAAK0AAAAnCAYAAAB9hMj9AAAAAXNSR0IArs4c6QAAAARnQU1BAACxjwv8YQUAAAAJcEhZcwAADsQAAA7EAZUrDhsAAACoSURBVHhe7dKxEcIwEABBQUZNroQWaYSOSE1iYxIzJrzxbqIfSZ/d5fF8zWO1Td/jYZ+dP5d/ft95XK/v022ZOIvrckKGaMkRLTmiJUe05IiWHNGSI1pyREuOaMkRLTmiJUe05IiWHNGSI1pyREuOaMkRLTmiJUe05IiWHNGSI1pyREuOaMkRLTmiJUe05IiWHNGSI1pyREuOaMkRLTmiJUe05IiWmDHeR1ELSoXHNogAAAAASUVORK5CYII=
	ENDTEXT

	TEXT to m.myvar2 noshow
	iVBORw0KGgoAAAANSUhEUgAAAK0AAAAnCAYAAAB9hMj9AAAAAXNSR0IArs4c6QAAAARnQU1BAACxjwv8YQUAAAAJcEhZcwAADsQAAA7EAZUrDhsAAACSSURBVHhe7dIxEYAwAATBgAsKDOEXQymwAU1M3LDb/Au47X7Od4Rdx1yPv9jXQoZoyREtOaIlR7TkiJYc0ZIjWnJES45oyREtOaIlR7TkiJYc0ZIjWnJES45oyREtOaIlR7TkiJYc0ZIjWnJES45oyREtOaIlR7TkiJYc0ZIjWnJES45oyREtOaIlR7TkiJaYMT5AggRKWvA4aAAAAABJRU5ErkJggg==
	ENDTEXT

	TEXT to m.myvar3 noshow
    iVBORw0KGgoAAAANSUhEUgAAAK0AAAAnCAYAAAB9hMj9AAAAAXNSR0IArs4c6QAAAARnQU1BAACxjwv8YQUAAAAJcEhZcwAADsQAAA7EAZUrDhsAAACRSURBVHhe7dJBEYAwAAPBgjs0gDuqAXvwqYkbdj+JgNvuY74j7HrO9fiLfS1kiJYc0ZIjWnJES45oyREtOaIlR7TkiJYc0ZIjWnJES45oyREtOaIlR7TkiJYc0ZIjWnJES45oyREtOaIlR7TkiJYc0ZIjWnJES45oyREtOaIlR7TkiJYc0ZIjWnJES45oiRnjAyKCBEp4XbcCAAAAAElFTkSuQmCC
	ENDTEXT

	TEXT to m.myvar4 noshow
   iVBORw0KGgoAAAANSUhEUgAAAK0AAAAnCAYAAAB9hMj9AAAAAXNSR0IArs4c6QAAAARnQU1BAACxjwv8YQUAAAAJcEhZcwAADsQAAA7EAZUrDhsAAACJSURBVHhe7dJBEcAwDMCwbADKn9JQZZ+S8J30MQE/+50dCHlvIcO05JiWHNOSY1pyTEuOackxLTmmJce05JiWHNOSY1pyTEuOackxLTmmJce05JiWHNOSY1pyTEuOackxLTmmJce05JiWHNOSY1pyTEuOackxLTmmJce05JiWHNOSY1pyTEvMzA+IBQMj9lrdxwAAAABJRU5ErkJggg==
	ENDTEXT


	With _Screen
		.AddProperty("pict1",Strconv(m.myvar1,14))
		.AddProperty("pict2",Strconv(m.myvar2,14))
		.AddProperty("pict3",Strconv(m.myvar3,14))
		.AddProperty("pict4",Strconv(m.myvar4,14))
	Endwith
	Endproc

Enddefine
*
*-- EndDefine: yitem

note:FoxRibbon of Guillermo Carrero (2Mo) can downloaded at :https://sites.google.com/site/foxribbonclass/

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

*4* created on Monday 15 of may 2017 and updated same date with 5 background styles.
*this code builds a special list from the button class ycommand.
*its a long listing of any field of a cursor (or combination of fields)
*mouseMove on any item to see the developped informations in the right editbox
*the editbox appears where its need (move with form scroll).
*the class ycommand can create any commandbutton with the effects encapsuled.
*rightclick on editbox to copy its contents to clipboard
*actions are codes to run from each item.for demo,i coded the 3 first items to run notepad,mspaint,calc.
*5 styles background (encoded base64 images) are set (choose one and adapt label1.forecolor for view)
*i added my custom form exiting effect.

Local m.re
m.re=Inputbox("styles 1,2,3,4,5","","1")
If Empty(m.re)
	m.rep="1"
Endi
m.re=Int(Val(m.re))
_Screen.AddProperty("xpict",m.re)
_Screen.AddProperty("yforecolor",0)

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

Sys(2002)  &&set curs off
Publi yform
yform=Newobject("yspecial_list")
yform.Show
Read Events
Retu
*
Define Class yspecial_list As Form
	AutoCenter=.T.
	Top = 0
	Left = 0
	Height = 500
	Width = 900
	ScrollBars=2
	ShowWindow = 2
	WindowState=2
	BackColor=Rgb(212,210,208)
	Caption = "MouseMove on list or click any item"
	Name = "Form1"

	Add Object edit1 As EditBox With;
		left=550+10,;
		top=100,;
		width=300,;
		height=220,;
		borderstyle=0,;
		fontbold=.T.,;
		scrollbars=0,;
		name="edit1"

	Add Object yshp As Shape With;
		left=550+5,;
		top=100+5,;
		width=300,;
		height=220,;
		borderstyle=0,;
		backcolor=Rgb(72,72,72),;
		curvature=5,;
		name="yshp"

	Procedure Init
	Local m.interspace
	m.interspace=-3  &&1
	With Thisform
		Sele ycurs
		Scan
			i=Recno()

			.AddObject("ycommand"+Trans(i),"ycommand")
			With Eval(".ycommand"+Trans(i))
				DoDefault()

				.Width=450
				.Height=30
				.Left=15
				If i=1
					.Top=10
				Else
					.Top=Eval("thisform.ycommand"+Trans(i-1)+".top")+Eval("thisform.ycommand"+Trans(i-1)+".height")+m.interspace
				Endi
				.label1.Caption=Trans(i)+" "+Allt(contact)+"-"+Allt(address)
				.Name="ycommand"+Trans(i)
				.Visible=.T.
			Endwith
		Endscan

		.AddObject("yclose","ycommand")
		With Eval(".yclose")
			DoDefault()
			.Left=Thisform.Width-100
			.Top=10
			.Width=80
			*.height=34
			.label1.Caption="Exit"
			.label1.Alignment=2
			.Visible=.T.
			.Name="yclose"
		Endwith
	Endwith
	Endproc

	Procedure yactions()
	Lparameters N
	*code any action to do from here
	Do Case
	Case N=0    &&button yclose
		*thisform.release
		Thisform.QueryUnload()      &&release or not
	Case N=1
		Run/N notepad
	Case N=2
		Run/N mspaint
	Case N=3
		Run/N Calc
		*case n= *********
	Otherwise
		Messagebox(loObject.Parent.Name+" clicked...write some code from here !",0+32+4096,"",1000)
	Endcase
	Endproc

	Procedure edit1.RightClick
	_Cliptext=This.Value
	Messagebox("contents in clipboard",0+32+4096,'',1100)
	Endproc

	Procedure yAction1()
	Lparameters nREC,nYcoord
	Sele ycurs
	Try
		Go nREC
		Local m.va
		m.va=""
		For i=1 To Fcount()
			m.va=m.va+Field(i)+" :"+Trans(Eval(Field(i)))+Chr(13)
		Endfor
		Rand(-1)
		With Thisform.edit1
			.Top=nYcoord
			.Parent.yshp.Top=.Top+10
			.Parent.yshp.Left=.Left+10
			.Parent.yshp.ZOrder(1)
			.ForeColor=Rgb(255*Rand(),255*Rand(),255*Rand())
			.BackColor=Rgb(255,255,255)
			.Alignment=2
			.Value=m.va
			.Refresh
		Endwith
	Catch
	Endtry
	Endproc

	Procedure QueryUnload
	With Thisform
		Try
			.AddObject("zshape","shape")
		Catch
		Endtry

		With .zshape
			.Left=0
			.Top=0
			.Width=.Parent.Width
			.Height=.Parent.Height
			.DrawMode=9
			.BackColor=Rgb(46,46,46)
			.ZOrder(0)
			.Visible=.T.
		Endwith
	Endwith

	If Messagebox("Want indeed to exit ?",4+64)=6
		DoDefault()
		Thisform.Release
	Else
		Thisform.RemoveObject("zshape")
		Nodefault
		Return .F.
	Endi
	Endproc

	Procedure Destroy
	Clea Events
	Endproc

Enddefine
*
*-- EndDefine: ySpecial_list
*
Define Class ycommand As Container
	Width = 139
	Height = 40
	ybutton1 = .F.
	ybutton2 = .F.
	ybutton3=.F.
	Name = "ycommand"

	Add Object label1 As Label With ;
		Alignment = 0, ;
		autosize=.T.,;
		Caption = "Label1", ;
		forecolor=_Screen.yforecolor,;
		Height = 25, ;
		Left = 15, ;
		Top = 12, ;
		Width = 109, ;
		Name = "Label1"

	Add Object image1 As Image With ;
		Height = 37, ;
		Left = 3, ;
		Top = 3, ;
		Width = 133, ;
		Name = "Image1"

	Procedure my
	Lparameters nButton, nShift, nXCoord, nYcoord
	*--- aevent create an array laEvents
	Aevents( myArray, 0)
	*--- reference the calling object
	loObject = myArray[1]
	N=Int(Val(Substr(loObject.Parent.Name,9)))
	Thisform.yactions(N)
	Endproc

	Procedure Init

	Local m.rep,m.myvar1
	m.rep=_Screen.xpict    &&int(val(m.rep))

	Local m.myvar
	Do Case
	Case m.rep=1
		TEXT to m.myvar1 noshow
iVBORw0KGgoAAAANSUhEUgAAAGgAAAASCAIAAAA4xwxRAAAAAXNSR0IArs4c6QAAAARnQU1BAACxjwv8YQUAAAAJcEhZcwAADsMAAA7DAcdvqGQAAAB6SURBVFhH7djLCcJgAAThf/pvQhBBEBE1GCIhB2+K4jNKxF60Bvc8Xwlz22X3+Rb9j+5tuATtYLgEzctwCTa94RKsH4ZLsLwZLsFob7gE44PhEkyOhkswPRkuwexsuATzi+ESLK6GS7C6Gy5B5XKIUD8Nl2DrOxIo5QcWJy1PlSw2ZAAAAABJRU5ErkJggg==
		ENDTEXT
		_Screen.yforecolor=0

	Case m.rep=2
		TEXT to m.myvar1 noshow
iVBORw0KGgoAAAANSUhEUgAAAIQAAAAjCAYAAABVXaLxAAAAAXNSR0IArs4c6QAAAARnQU1BAACxjwv8YQUAAAAJcEhZcwAADsMAAA7DAcdvqGQAAAKCSURBVHhe7dK5kRgGDARBxXX/m39IFJylYDSprbNhdAQz/3x/f//6P19fXz/2+fn5Yx8fH3/1/v7+Y29vb3/0+vr6Yy8vL3/1/Pz8Y09PT3/0+Pj4Yw8PD7/dEKDQLU2wKXRLI4RCt26IoRFCoVuaYFPolkYIhW7dEEMjhEK3NMGm0C2NEArduiGGRgiFbmmCTaFbGiEUunVDDI0QCt3SBJtCtzRCKHTrhhgaIRS6pQk2hW5phFDo1g0xNEIodEsTbArd0gih0K0bYmiEUOiWJtgUuqURQqFbN8TQCKHQLU2wKXRLI4RCt26IoRFCoVuaYFPolkYIhW7dEEMjhEK3NMGm0C2NEArduiGGRgiFbmmCTaFbGiEUunVDDI0QCt3SBJtCtzRCKHTrhhgaIRS6pQk2hW5phFDo1g0xNEIodEsTbArd0gih0K0bYmiEUOiWJtgUuqURQqFbN8TQCKHQLU2wKXRLI4RCt26IoRFCoVuaYFPolkYIhW7dEEMjhEK3NMGm0C2NEArduiGGRgiFbmmCTaFbGiEUunVDDI0QCt3SBJtCtzRCKHTrhhgaIRS6pQk2hW5phFDo1g0xNEIodEsTbArd0gih0K0bYmiEUOiWJtgUuqURQqFbN8TQCKHQLU2wKXRLI4RCt26IoRFCoVuaYFPolkYIhW7dEEMjhEK3NMGm0C2NEArduiGGRgiFbmmCTaFbGiEUunVDDI0QCt3SBJtCtzRCKHTrhhgaIRS6pQk2hW5phFDo1g0xNEIodEsTbArd0gih0K0bYmiEUOiWJtgUuqURQqFbN8TQCKHQLU2wKXRLI4RCt26IoRFCoVuaYFPolkYIhW79N8TDr38Bwsd+Nta8TyEAAAAASUVORK5CYII=
		ENDTEXT
		_Screen.yforecolor=Rgb(255,255,255)

	Case m.rep=3
		TEXT to m.myvar1 noshow
iVBORw0KGgoAAAANSUhEUgAAAIIAAAAcCAYAAACtb2fOAAAAAXNSR0IArs4c6QAAAARnQU1BAACxjwv8YQUAAAAJcEhZcwAADsQAAA7EAZUrDhsAAAIdSURBVGhD7ZnNUsMwDIQTp4/AwHBihvd/R7O7khynP9DCqcN+kFjWSrKd6JSuy7J0XE/BhosbJrTJCVf5aPMw29L0R7YWkdu2LesakafTadj0t4ZoXLf085GxvXfFzb6yH6lzza7xnjrMo879/LYOcyLL/HvcCEa4EYxwIxjhRjDCjWCEG8EIN4IRbgQj3AhGPFUj8PNxfQ+fx7KLnn+y+z6WTencf9DBbM/c8t9Fft6tz7zkmn2vzvHcR77zkWv6UzbCfJFLX91jxNuLkfCFl/8G1xriLw0wHrzuj3PzJdLEWDbHX12tLevn67tOiHlCMSz+FFEPra3smXwoOY8wzFgopP2wDXXSR5vwDm8WkEvzlOGGHSaEWE85qTMpUrEr6VkzA2q5VWuPWdwxRDXa0PCfM+XRp/MyLwQMYVBvKEBNnlyPd/r4o001ykGHb+TKQz00Ppy1x/ON8MzhjVvQw6u90Un2c/HMo+a0HoPpH2+rIycnldERc9C5l4+XN50hfrTCtrA52txg/SZVhy1qHptGJOwqHGV2H20WDI0PEt4M1BpYL97ptOKcg1vpUYG+WUdN2MVhb5Wj8Nk+VBv6xd5ogKopKQtk2NDIz3rWhNixHu0Ij+g9Z/LJhrlnH2umregMjkyp0JGDyfAhZrybSY+5+fe4EYxwIxjhRjDCjWCEG8EIN4IRbgQj3AhGuBGMcCMY4UYwwo1gwLJ8AVfF+kFQkQZfAAAAAElFTkSuQmCC
		ENDTEXT
		_Screen.yforecolor=Rgb(255,255,255)

	Case m.rep=4
		TEXT to m.myvar1 noshow
iVBORw0KGgoAAAANSUhEUgAAAJQAAAAoCAYAAAAYNNPaAAABwElEQVR4nO3cMUscURTF8f9k7iQoogMWEmystIkfwC6IkCKmsFAJaCPERUiTj5HGymabBQkYgqBFgoVtLC0t7NRGEoigsiBmZhgLsxKwCXrhZR/n105zisM7U92krms6rr6+fw40gEVgGHiGyH0XwCGwA6z2vFlrdz4knUK1txvTwBegN0RC6Vo/gHd9M81v8KdQ55tLC8A68CRoNOlW18BUPtvaS35tLOTAMTAQNpN0uTNgxKqi+IDKJI83CMxZVRZToZNINFasLIsXoVNINEatKov+0CkkGv1WlUXoEBIRK1UocaQXSlxZVfwOnUEioskTV5o8caVCiSsVSlzpH0pcWVWoUOJHkyeuNHniSi+UuLLUstAZJCJmKpQ40gslrizNVCjxo8kTV5o8caVCiSsVSlzpH0pcWZo9DZ1BIqLJE1eaPHFlqWXX6LCY+Dix1LJjYCx0EonCvpllLeBj6CQShd3k5/p8DhwBeeg00tUOgfGkrmvOPi9OcnuAU/9S8hCXwPTg20/f7462nm8uvQaa3F7/FflXp8CrfLZ1AH9dAQZobzd6gGVgAngJDAUIKP+/C+AAWAO2+maadwcybgDQIHzWrpJYGwAAAABJRU5ErkJggg==
		ENDTEXT
		_Screen.yforecolor=0

	Case m.rep=5
		TEXT to m.myvar1 noshow
iVBORw0KGgoAAAANSUhEUgAAAJEAAAAoCAYAAAD+HRieAAABSElEQVR4nO3cMUoDQRxG8Tc4gifQ0itYWAhiY2kuIqiICOIBomJvkYNY2wQ7wdoyCEJQsBJDdsNYiJ2V/2IceL8TfMVjlt2FSaUUABIMgCNgA1hD+t0UeASGBe4BUimF1PVXwHnVaWrReVnO14mPzwFwW3uNmrQAtnLq+oPaS9SsJeA0pdf3KbBae42a9ZzSy1upvUJty3R97Q1qnBEpzIgUlpMRKciTSGFGpDAjUpgRKcyIFJZTt6i9QY3zJFKYESnMiBRmRArzt4fCPIkUZkQKMyKFGZHCMn6xVpBvZwrzcaYwI1KYESnMiBRmRArz7UxhnkQKMyKFZbrFFK/X099NMl3/wPd9jdJfjDNdfwnsAan2GjVnDgxTKYWV3cMz4ALIlUepHXPgeHZ3M0o/VxCv7OxvAifANrBecZz+twkwBoaz8egJ4At6yXX6SIl7EAAAAABJRU5ErkJggg==
		ENDTEXT
		_Screen.yforecolor=0

	Endcase

	Local m.myvar2   && mouseleave encoded base64 images
	TEXT to m.myvar2 noshow
	iVBORw0KGgoAAAANSUhEUgAAAGcAAAASCAIAAADJzFfcAAAAAXNSR0IArs4c6QAAAARnQU1BAACxjwv8YQUAAAAJcEhZcwAADsMAAA7DAcdvqGQAAAB2SURBVFhH7cKhCsIAAEXR95XGVavZumizrBgsgnksGv0BmyADQUTUMdkQg+XtG25/hyP/T0nLv2PS8veQtDzUScv9Lmn5vUlafq6Tls+zpOVLkbTczpOWr4uk5dsyafleJi0/VknLryppudsmLX/2Sctjk+zYTLBOC5DrQFA2AAAAAElFTkSuQmCC
	ENDTEXT

	This.ybutton1=Strconv(m.myvar1,14)
	This.ybutton2=Strconv(m.myvar2,14)

	With This
		.BackStyle=0
		.BorderWidth=0

		With .image1
			.MousePointer=15
			.Stretch=2
			.Anchor=15
			.Left=0
			.Top=0
			.Width=.Parent.Width
			.Height=.Parent.Height
			.ZOrder(1)
			.PictureVal=This.ybutton1
		Endwith

		With .label1
			.FontBold=.T.
			.FontSize=10
			.MousePointer=15
			.BackStyle=0
			.AutoSize=.T.
			.Left=20
			.Top =(.Parent.Height-.Height)/2
			.ForeColor=_Screen.yforecolor
		Endwith

		Bindevent(.image1,"mousedown",This,"my")
		Bindevent(.label1,"mousedown",This,"my")
	Endwith
	DoDefault()
	Endproc

	Procedure label1.MouseLeave
	Lparameters nButton, nShift, nXCoord, nYcoord
	DoDefault()
	This.ForeColor=_Screen.yforecolor
	This.Parent.image1.PictureVal=This.Parent.ybutton1
	This.Parent.BorderWidth=0
	Endproc

	Procedure label1.MouseEnter
	Lparameters nButton, nShift, nXCoord, nYcoord
	DoDefault()
	This.ForeColor=255
	This.Parent.image1.PictureVal=This.Parent.ybutton2
	This.Parent.BorderWidth=1
	Thisform.yAction1(Int(Val(Substr(This.Parent.Name,9))),nYcoord)
	Endproc

	Procedure image1.MouseLeave
	Lparameters nButton, nShift, nXCoord, nYcoord
	DoDefault()
	This.PictureVal=This.Parent.ybutton1
	This.Parent.BorderWidth=0
	Endproc

	Procedure image1.MouseEnter
	Lparameters nButton, nShift, nXCoord, nYcoord
	DoDefault()
	This.PictureVal=This.Parent.ybutton2
	This.Parent.BorderWidth=1
	Thisform.yAction1(Int(Val(Substr(This.Parent.Name,9))),nYcoord)

	Endproc

Enddefine
*
*-- EndDefine: ycommand

see the form caption dont appear firstly.must make some resize to activate it.its a bug in vfp9SP2.see also the elevator effect of the editbox.combining image and forecolor can invent too styles.To avoid form scroll can embed all controls in a scrollable previous container as well.

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

*5* created on tuesday 16 of may 2017
*!*	this code builds a themed form with a subclassed titlebar.
*!*	there is 6 styles can be applied in bottom optionGroup dynamically.
*!*	6 images encoded base 64 are implemented in code.
*!*	form is movable by mousedown on subclassed titlebar.
*!*	a container class form system set (reduce max,restore,close).
*!*	rightclick on editbox to fire the contextuel menu

_screen.windowstate=1
PUBLI YFORM
yform=NewObject("ythemed")
yform.show
read events
retu
*
DEFINE CLASS ythemed AS form
Height = 525
Width = 685
ShowWindow = 2
ShowTips = .T.
AutoCenter = .T.
Caption = "My form title goes here"
MinHeight = 500
MinWidth = 600
TitleBar = 1
keyPreview=.t.
borderstyle=0  && borderstyle=3 for resizable form
yf = .F.

ADD OBJECT image1 AS image WITH ;
	Anchor = 0, ;
	Picture = "", ;
	Stretch = 2, ;
	Height = 48, ;
	Left = 0, ;
	Top = 0, ;
	Width = 648, ;
	Name = "Image1"

ADD OBJECT ytitle AS label WITH ;
	FontBold = .T., ;
	FontSize = 12, ;
	Anchor = 768, ;
	Alignment = 0, ;
	BackStyle = 0, ;
	Caption = "", ;
	Height = 24, ;
	Left = 54, ;
	Top = 6, ;
	Width = 534, ;
	ForeColor = RGB(255,255,0), ;
	Name = "ytitle"

ADD OBJECT edit1 AS editbox WITH ;
	FontBold = .T., ;
	FontSize = 10, ;
	Anchor = 15, ;
	BorderStyle = 0, ;
	Height = 445, ;
	Left = 0, ;
	Margin = 10, ;
	ScrollBars = 2, ;
	Top = 48, ;
	Width = 648, ;
	ForeColor = RGB(255,255,255), ;
	BackColor = RGB(0,0,0), ;
	Name = "Edit1"

ADD OBJECT image2 AS image WITH ;
	Anchor = 0, ;
	Picture = "", ;
	Stretch = 2, ;
	Height = 37, ;
	Left = -3, ;
	Top = 492, ;
	Width = 651, ;
	Name = "Image2"

ADD OBJECT image3 AS image WITH ;
	Anchor = 768, ;
	Stretch = 2, ;
	BackStyle = 1, ;
	Height = 33, ;
	Left = 5, ;
	Top = 1, ;
	Width = 33, ;
	mousepointer=15,;
	Name = "Image3"

ADD OBJECT optiongroup1 AS optiongroup WITH ;
	AutoSize = .T., ;
	ButtonCount = 6, ;
	Anchor = 768, ;
	BackStyle = 0, ;
	BorderStyle = 0, ;
	Value = 1, ;
	Height = 28, ;
	Left = 12, ;
	Top = 496, ;
	Width = 132, ;
	ToolTipText = "6 styles", ;
	Name = "Optiongroup1", ;
	Option1.Caption = "", ;
	Option1.Value = 1, ;
	Option1.Height = 17, ;
	Option1.Left = 5, ;
	Option1.Style = 0, ;
	Option1.Top = 5, ;
	Option1.Width = 18, ;
	Option1.AutoSize = .F., ;
	Option1.Name = "Option1", ;
	Option2.Caption = "", ;
	Option2.Height = 17, ;
	Option2.Left = 25, ;
	Option2.Style = 0, ;
	Option2.Top = 6, ;
	Option2.Width = 18, ;
	Option2.AutoSize = .F., ;
	Option2.Name = "Option2", ;
	Option3.Caption = "", ;
	Option3.Height = 17, ;
	Option3.Left = 45, ;
	Option3.Style = 0, ;
	Option3.Top = 6, ;
	Option3.Width = 18, ;
	Option3.AutoSize = .F., ;
	Option3.Name = "Option3", ;
	Option4.Caption = "", ;
	Option4.Height = 17, ;
	Option4.Left = 65, ;
	Option4.Style = 0, ;
	Option4.Top = 6, ;
	Option4.Width = 18, ;
	Option4.AutoSize = .F., ;
	Option4.Name = "Option4", ;
	Option5.Caption = "", ;
	Option5.Height = 17, ;
	Option5.Left = 88, ;
	Option5.Top = 6, ;
	Option5.Width = 18, ;
	Option5.AutoSize = .T., ;
	Option5.Name = "Option5", ;
	Option6.Caption = "", ;
	Option6.Height = 17, ;
	Option6.Left = 109, ;
	Option6.Top = 6, ;
	Option6.Width = 18, ;
	Option6.AutoSize = .T., ;
	Option6.Name = "Option6"

ADD OBJECT ysys AS ysys WITH ;
	Anchor = 768, ;
	Top = 3, ;
	Left = 591, ;
	Width = 85, ;
	Height = 24, ;
	BackStyle = 0, ;
	BorderWidth = 0, ;
	Name = "ysys"
	
	procedure image3.click

   local m.myvar
   text to m.myvar pretext 7 noshow
this code builds a themed form with a subclassed titlebar.
there is 6 styles can be applied in bottom optionGroup dynamically.
6 images encoded base 64 are implemented in code.
form is movable by mousedown on subclassed titlebar.
a container class form system set (reduce max,restore,close).
rightclick on editbox to fire the contextuel menu
endtext
messagebox(m.myvar,0+32+4096,"summary help")
endproc

PROCEDURE ybuild
	local m.myvar
	text to m.myvar noshow
	R0lGODlhIAAhANUsACAgQCBAACBAQEAgAGBAAGBgAGBAQGBgQIBAAIBgAKBAAKBgAIBAQIBgQKBAQKBgQOBAAOBgAOBAQOBgQKCAAKCgAICAQICgQKCAQKCgQKDAQOCAAOCgAOCAQOCgQODAAODgAODAQODgQICAgKCgpKDAwKbK8ODggMDAwMDcwP/78P///wAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACH/C05FVFNDQVBFMi4wAwEAAAAh+QQFCgAsACwAAAAAIAAhAAAG/kCWcGjADI/IpPKISSCW0Cjr1Ng8jNLskETxcBrasMXrWZDC2caHTCmhoSlMKLTmdM7vZCpDD3G8GBl5SCkdIHMffhsNKFonJA8EDEMmGSIiiXUeGCgnJksZDwwICBFPQ5YhInMhXhuvGJxDKA0IDhEQERMQD0eWICKHH4l2HRERDZwYCBLHuc9gW5eqrH8cr7sKDLm4ExHNEAx4Qq2XwYl+HhsMx+3NuMcTCtGzFuaqmR0J2N/O/RAQ6A3RYOkeJg9dNhjjBmEXPEZIUKi6BGxVuj/Ycr3zBhFJwYnB+ljrsMHfMwcekqDQsKqAuWki+Xlr9mDckRKWNAwAGZKOpRdjuHI9aKQERSoDLy1q4ndMYJKP5iokIIDBAzF1xyQEjFLQXAYBASxdzajL6REUFkB+sNjTi52SvAQ9PdA1KcwPHDC82sAxhRIAO+2K4JCBQx99HoBKMCvEgkvBITJkCEQhAYZrJRv4XYJCjsULI1KcOHEJ3c91WOBksGChwQgSm0mvwquuA+M3J6pda3BiUJLZITBo9p0kd97UxI+k8JDBZpQgAAA7
	endtext
	thisform.image3.pictureVal=strconv(m.myvar,14)

	with thisform
	.addproperty("ybackg1","")
	.addproperty("ybackg2","")
	.addproperty("ybackg3","")
	.addproperty("ybackg4","")
	.addproperty("ybackg5","")
	.addproperty("ybackg6","")
	endwith

	text to thisform.ybackg1 noshow
	iVBORw0KGgoAAAANSUhEUgAAANcAAAAdCAIAAAC2bG4wAAAAAXNSR0IArs4c6QAAAARnQU1BAACxjwv8YQUAAAAJcEhZcwAADsMAAA7DAcdvqGQAAAJ4SURBVHhe7dLRSpphGAfw9zbcSXaUHVQnUQfqYlaLaotqq1W0WrSKVkRLJhYTncvmUvaRKekMlcgK/CLQIg1nNpVMGI3WBe15v4t4jv7wu4SfeKhUHqvVf7XaIwAjWa5apX4PNzfivlK5v739e3cHwIziUb8/xaK4KxZrpVKtXK5VKgB8qFypRP2q+bwo5/PlQqFSLAIwo3jU7/flpShcXBSy2etc7vrqCoBPLkfxqN+vdFpkz86y6XQuk8mdnwPwyWQonuynqiJ9cpJOpTKqmjk9BeCjqhRP9ksmRergIHV4qCaT6tERAJ9kkuLJfrGYON7fP4rFjuPx40QCgE88LuNRv0hEJEKh+N5eIhxORCIAfMJhGS8USgQCIqooP3d2ooFAdHcXgE8gIOMpStTvF0Gvd3d7O+jzBf1+AD4+n4zn9QY9HqG43T82NxWPR9naAuDj8ch4brficgmvw/HN6fQSlwuAj9Mp4zkc3zc2hNtm+2K3u8n6OgAfu13Gs9m+Wq3Csbr6eW1NsloB+GjrqJ9jZUXYFhc/LS1Jy8sAfLR11M+2sCA+zs6uzs1J8/MAfLR11G9tZkZ8mJxcnJqSpqcB+GjrqN/SxISYGx19PzYmjY8D8NHWUb/5kRExNTj4dmhIGh4G4KOto37vBgbEWG/vm74+qb8fgI+2jvpN9PSIV52dQ11dUnc3AB9tHfV7bbGIlybTC7O5H4AdxaN+A0aj6Glre07a27sBGFE5ikf9+lpbRWdzs6Wl5RkAO4pH/bqamkSHwfDUYDCTxkYAPlo86mdpaBBmvd6k1xvr6wGYUTzq11FXJ8w6nenJEyMAO4pH/Tp0uv9BFEE9YX9F+gAAAABJRU5ErkJggg==
	endtext
	thisform.ybackg1=strConv(thisform.ybackg1,14)

	text to thisform.ybackg2 noshow
	iVBORw0KGgoAAAANSUhEUgAAAIQAAAAjCAYAAABVXaLxAAAAAXNSR0IArs4c6QAAAARnQU1BAACxjwv8YQUAAAAJcEhZcwAADsMAAA7DAcdvqGQAAAKCSURBVHhe7dK5kRgGDARBxXX/m39IFJylYDSprbNhdAQz/3x/f//6P19fXz/2+fn5Yx8fH3/1/v7+Y29vb3/0+vr6Yy8vL3/1/Pz8Y09PT3/0+Pj4Yw8PD7/dEKDQLU2wKXRLI4RCt26IoRFCoVuaYFPolkYIhW7dEEMjhEK3NMGm0C2NEArduiGGRgiFbmmCTaFbGiEUunVDDI0QCt3SBJtCtzRCKHTrhhgaIRS6pQk2hW5phFDo1g0xNEIodEsTbArd0gih0K0bYmiEUOiWJtgUuqURQqFbN8TQCKHQLU2wKXRLI4RCt26IoRFCoVuaYFPolkYIhW7dEEMjhEK3NMGm0C2NEArduiGGRgiFbmmCTaFbGiEUunVDDI0QCt3SBJtCtzRCKHTrhhgaIRS6pQk2hW5phFDo1g0xNEIodEsTbArd0gih0K0bYmiEUOiWJtgUuqURQqFbN8TQCKHQLU2wKXRLI4RCt26IoRFCoVuaYFPolkYIhW7dEEMjhEK3NMGm0C2NEArduiGGRgiFbmmCTaFbGiEUunVDDI0QCt3SBJtCtzRCKHTrhhgaIRS6pQk2hW5phFDo1g0xNEIodEsTbArd0gih0K0bYmiEUOiWJtgUuqURQqFbN8TQCKHQLU2wKXRLI4RCt26IoRFCoVuaYFPolkYIhW7dEEMjhEK3NMGm0C2NEArduiGGRgiFbmmCTaFbGiEUunVDDI0QCt3SBJtCtzRCKHTrhhgaIRS6pQk2hW5phFDo1g0xNEIodEsTbArd0gih0K0bYmiEUOiWJtgUuqURQqFbN8TQCKHQLU2wKXRLI4RCt26IoRFCoVuaYFPolkYIhW79N8TDr38Bwsd+Nta8TyEAAAAASUVORK5CYII=
	endtext
	thisform.ybackg2=strConv(thisform.ybackg2,14)

	text to thisform.ybackg3 noshow
	iVBORw0KGgoAAAANSUhEUgAAAIIAAAAcCAYAAACtb2fOAAAAAXNSR0IArs4c6QAAAARnQU1BAACxjwv8YQUAAAAJcEhZcwAADsQAAA7EAZUrDhsAAAIdSURBVGhD7ZnNUsMwDIQTp4/AwHBihvd/R7O7khynP9DCqcN+kFjWSrKd6JSuy7J0XE/BhosbJrTJCVf5aPMw29L0R7YWkdu2LesakafTadj0t4ZoXLf085GxvXfFzb6yH6lzza7xnjrMo879/LYOcyLL/HvcCEa4EYxwIxjhRjDCjWCEG8EIN4IRbgQj3AhGPFUj8PNxfQ+fx7KLnn+y+z6WTencf9DBbM/c8t9Fft6tz7zkmn2vzvHcR77zkWv6UzbCfJFLX91jxNuLkfCFl/8G1xriLw0wHrzuj3PzJdLEWDbHX12tLevn67tOiHlCMSz+FFEPra3smXwoOY8wzFgopP2wDXXSR5vwDm8WkEvzlOGGHSaEWE85qTMpUrEr6VkzA2q5VWuPWdwxRDXa0PCfM+XRp/MyLwQMYVBvKEBNnlyPd/r4o001ykGHb+TKQz00Ppy1x/ON8MzhjVvQw6u90Un2c/HMo+a0HoPpH2+rIycnldERc9C5l4+XN50hfrTCtrA52txg/SZVhy1qHptGJOwqHGV2H20WDI0PEt4M1BpYL97ptOKcg1vpUYG+WUdN2MVhb5Wj8Nk+VBv6xd5ogKopKQtk2NDIz3rWhNixHu0Ij+g9Z/LJhrlnH2umregMjkyp0JGDyfAhZrybSY+5+fe4EYxwIxjhRjDCjWCEG8EIN4IRbgQj3AhGuBGMcCMY4UYwwo1gwLJ8AVfF+kFQkQZfAAAAAElFTkSuQmCC
	endtext
	thisform.ybackg3=strConv(thisform.ybackg3,14)

	text to thisform.ybackg4 noshow
	iVBORw0KGgoAAAANSUhEUgAAAOEAAAAjCAYAAABik23FAAAAAXNSR0IArs4c6QAAAARnQU1BAACxjwv8YQUAAAAJcEhZcwAADsMAAA7DAcdvqGQAAAbeSURBVHhe7dfpqxZ1GMbxeVVapCaSJplZmoZLppaiIuWuuHvK477mnkdFc0nSxA2X3DWlVE4Wgp7UVFwIKTJyAdEH4WCNiMuIOgPmDDJyxpmr64L6B+Z5e7/48sAzv9/LD/f9c86NH49Lc+bg6rJlqPz6a7i7d+NmeTluHTiAOwcP4m5FBbzDhy3LKjJZkinZkjFZkznn/NSpuLJ4MSrXrsWNXbtwe/9+3PvpJzw4fhwPT55EcOYMgl9+sSyr2GhJpmRLxmRN5pxLM2fi2tKlcDdvxu29e3H/0CEEJ07gES89/vVXhL//jujcOcuyikyWZEq2ZEzWZM65XFaGyuXLcXPbNtyjzODoUfxDsREPP/njD8TnzyO+cMGyrGKjJZmSLRmTNZlzrhDhdSK8tX07HvCPR/wQ8UD82294ygtVvFh18SISy7JyJ0OyJFOyJWOyJnPOVSL8iwjvcBI+/P57PD5yBE9On8ZTak144dmffyKlYsuyikuWZEq2ZEzWZM4p8E34N9+EdzdtQrBvH0LuqTH31Srurc94OOUem3GfzXjZsqyc0ZAsyZRsyZisyZxTmD4d7pIl8DZsQPDtt4gOHEDMMVl18iRSHs7OngV40bKs4pIlmZItGZM1mXMKkyfDXbAA3po1CHbuRFRejvjgQSQ//4yUWrNTpwCOTnCHtSwrZzQkSzIlWzIW0pq/YwcRTpwId948eCtWINiyBdF33yH+4QckHJXp4cPIeAHHjgHHj1uWlTcakiWZki0ZCzkF/c2biXDsWLhlZfD4LgzWr0fEaRjv3YuEh1KOy4xiwUuoqLAsK280JEsyJVsyFnIK+uvWEeHIkXD5LvQWLUKwahUiyox37UKyZw9Sjsts/36Al/Djj5Zl5Y2GZEmmZEvGwk2b4NOcUygthTtlCrz58xEsX46I0zDeuhUJD6UclxkvgGqxb59lWXmjIVmSKdmSsZBT0P/qKyIsKYE7YQK82bMRLFmCaOVKxBs2IOH7MN2+HRnXU3zzDcCLlmXljIZkSaZkS8ZCWvO/+IIIBw2CO2YMvBkzECxYgGjZMsSrVyPhREw3bkTG9RS8BMq1LCtnNCRLMiVbMhbSmv/550TYvz/cESPgTZ6MYM4cRIsXI+aITKg0XbMG2dq1AMcmeNGyrJzRkCzJlGzJWLhoEXyacwp9+sD95BN4XEmDmTMR8W0Yc0QmVJryjZitWAHwEviAtCwrZzQkSzIlWzIWzpsHn+acQo8ecAcPhjd6NIIpUxCVlSEmxIRKU74Rsy+/BNTSpZZl5Y2GZEmmZEvGwlmz4HMDdQpdu8LlSuqVliIYPx7RtGmI+TGZOxcpD2Z8J0ItXGhZVt5oSJZkSrZkLJw6FT7NOYUuXeByJfWGDkUwahSiiRMRE2Ly2WdIORUz7qxQvGhZVs5oSJZkSrZkLKQ1n+acQseOcLt3hzdgAAK+DSOupTHfhwnHZEqp2fTpgJoxw7KsvNGQLMmUbMlYSGs+zTmF9u3hfvQRvL59EQwZgohracyPybhxSHkwmzQJUJ9+allW3mhIlmRKtmQsHDYM/uDBRNi2LdzOneH16IGgXz9EhBhTZzJ8ONKRI5HxMNSYMZZl5Y2GZEmmZEvGQgL0ac4ptG4Nt0MHeB9+iKBXL0T9+yPmx6SkBOnHHyOjVihOSMuyckZDsiRTsiVjIQH6NOcUWrSA264dvE6dEHAtjXr2RMzVNCHGdOBAZIMGAYqXLMvKGQ3JkkzJloyFtObTnFNo1gzuu+/C++ADBFxLI07EuHt3JDyQ9u6NrE8fQPGSZVk5oyFZkinZkrGQ1nwOP6fQpAnc5s3hvfcegvbtEfHPuEsXJBSadu2KrFs3QPGSZVk5oyFZkinZkrGQ1nwOP6fQqBHcpk3hcS0NCDF6/33ExFjVsSNSHso4HWFZVtHJkkzJlozJmsw5hddfx99vvYW7hBgQYsjVNG7TBlVt2+IZD6Uso1bLsopLlmRKtmRM1mTOufrqq/iLEO+8+SYevv02Hr/zDp5wPX3Kj0nLlnjWqhVSy7KKTpZkSrZkTNZkzrnyyiu4Toi3GjTAgzfewCNOxahxY8T8+JTTsUo1a4bEsqzcyZAsyZRsyZisyZxz+eWXUVmnDm7WrYt79esjeO01/EOQEafjk4YNESsetCyryGhJpmRLxmRN5pxLL72Ea7Vqwa1dG7eJ8T4nY0CQj+rVw2MWckpGTL+WZeXrf0MyJVsyJmsy55yvXh1XXnwRlcR4o0YN3K5ZE/eI8gEn5EMW/JdvWVbu/nckU7IlY7Imc865557Dpeefx9Vq1VDJXKK8+cILuMXusLvMI1LLsopLlmRKtmRM1iqrVcO/RSCeDt+EBYwAAAAASUVORK5CYII=
	endtext
	thisform.ybackg4=strConv(thisform.ybackg4,14)

	text to thisform.ybackg5 noshow
	iVBORw0KGgoAAAANSUhEUgAAAIUAAAAoCAYAAADQWDkMAAAAAXNSR0IArs4c6QAAAARnQU1BAACxjwv8YQUAAAAJcEhZcwAADsQAAA7EAZUrDhsAAAEiSURBVHhe7dIxK8RhAMfx5/f8/89zb8pisVgsFotFSYrhBlIMN1CXFMMNlBhuoCTFcAMlqRsoSTHcQEmKoiTF8Lfe7z18P6/ho1BVVQD6KPz+kQJG4fuHFDDS5xcpYKS3D1LASC/vpICRnl5JASP1nkkBI90/kgJG8bZHChjF6wdSwCh270gBo3hxQwoYxbMrUsAodrqkgFFxfEkKGBWH56SAUbF/SgoYFe0OKWBU7JyQAkbl1hEpYFS2DkgBo3J9jxQwKlfbpIBRubJLChiVjW1SwCgtbpICRmm+RQoYpfoGKWCUZtZIAaM01SQFjNLEMilglMcbpIBRHlsiBYzy6AIpYJRH5kgBozxcJwWM8tAsKWBUG5wmBYxqA5OkQJ8Q/gGAG10eE4ruQwAAAABJRU5ErkJggg==
	endtext
	thisform.ybackg5=strConv(thisform.ybackg5,14)

	text to thisform.ybackg6 noshow
	iVBORw0KGgoAAAANSUhEUgAAAIgAAAAoCAYAAAAlprK8AAAAAXNSR0IArs4c6QAAAARnQU1BAACxjwv8YQUAAAAJcEhZcwAADsQAAA7EAZUrDhsAAAEqSURBVHhe7dwhS0NRHIbx+4YJw2KxWCyWFcuSxWKxWCwWQUTQYNCwYDAYLAaDwWAwWAwG02RhIBgEQTAIgkEYGARhIKgIgngtA2HjfT/B82unP1zuved/jr6aG2Xx+1MA/VSpFvo4Xy17a2CA3s6WCQSWuqeLBAJLrycLBAJLL8fzBAJLz0dzBAJLncNZAoGlp4MZAoGlx/1pAoGlh70pAoGl+906gcDS3c4kgcDS7XaNQGDpZmuCQGDpujFOILB0tTlGILB0uT5KILDUXhshEFhqrQwTCCw1l4YIBBZPEES8gyDiKwYR/0EQ8ScVEXsxiNjNRcQ8CCImyhAxk4qIqXZEnItBxMk6RJzNRcTpfkTcD4KIG4YQcUcZIn1eNMry+723BP6pUi3+AJHnbJNh44K6AAAAAElFTkSuQmCC
	endtext
	thisform.ybackg6=strConv(thisform.ybackg6,14)

	thisform.image1.pictureVAL=thisform.ybackg1
	thisform.image2.pictureVal=thisform.ybackg1
ENDPROC

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

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

PROCEDURE Load
	Declare Integer ReleaseCapture In WIN32API
	Declare Integer SendMessage In WIN32API Integer, Integer, Integer, Integer
ENDPROC

PROCEDURE Resize
	with this.image1
	.left=0
	.top=0
	.width=.parent.width
	.zorder(1)
	endwith

	with this.image2
	.left=0
	.top=.parent.height-.height
	.width=.parent.width
	.zorder(1)
	endwith
ENDPROC

PROCEDURE Init

with thisform
.titlebar=0
.optionGroup1.setall("mousepointer",15,"Optionbutton")
.ybuild()
endwith

ENDPROC

PROCEDURE Destroy
  yform=null
  release yform
	CLEA EVENTS
ENDPROC

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

PROCEDURE ytitle.MouseDown
Lparameters nButton, nShift, nXCoord, nYCoord
	thisform.image1.mousedown(1)
ENDPROC

PROCEDURE ytitle.MouseDown
	LPARAMETERS nButton, nShift, nXCoord, nYCoord
	thisform.image1.mousedown(1)
ENDPROC

PROCEDURE ytitle.Init
	this.caption=thisform.caption
ENDPROC

PROCEDURE edit1.Init
	text to this.value pretext 7 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.
	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

	with this
	.left=0
	.width=.parent.width
	.anchor=15
	endwith
ENDPROC

PROCEDURE edit1.RightClick
	SET COLOR OF SCHEME 1 TO N+/w*,GR+/N*,,,,W+/R
	 Define Popup raccourci SHORTCUT Relative From Mrow(),Mcol() color scheme 1
			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"
		   DEFINE BAR 1 OF raccourci PROMPT "forecolor"
		  ON SELECTION BAR 1 OF raccourci _screen.activeform.edit1.forecolor=getcolor()
		
		 DEFINE BAR 2 OF raccourci PROMPT "increase fontsize"
		  ON SELECTION BAR 2 OF raccourci _screen.activeform.edit1.fontsize=_screen.activeform.edit1.fontsize+1
		
		 DEFINE BAR 3 OF raccourci PROMPT "decrease fontsize"
		  ON SELECTION BAR 3 OF raccourci _screen.activeform.edit1.fontsize=_screen.activeform.edit1.fontsize-1
				
		   DEFINE BAR 4 OF raccourci PROMPT "fontname"
		  ON SELECTION BAR 4 OF raccourci _screen.activeform.edit1.fontname=getwordnum(getfont(),1,',')
			
			Activate Popup raccourci
ENDPROC

PROCEDURE optiongroup1.Click
	do case
	case this.value=1
	thisform.image1.pictureVal=thisform.ybackg1
	thisform.image2.pictureVal=thisform.ybackg1

	case this.value=2
	thisform.image1.pictureVal=thisform.ybackg2
	thisform.image2.pictureVal=thisform.ybackg2

	case this.value=3
	thisform.image1.pictureVAl=thisform.ybackg3
	thisform.image2.pictureVAl=thisform.ybackg3

	case this.value=4
	thisform.image1.pictureVal=thisform.ybackg4
	thisform.image2.pictureVal=thisform.ybackg4
	case this.value=5
	thisform.image1.pictureVal=thisform.ybackg5
	thisform.image2.pictureVal=thisform.ybackg5

	case this.value=6
	thisform.image1.pictureVal=thisform.ybackg6
	thisform.image2.pictureVal=thisform.ybackg6
	endcase
ENDPROC

 procedure keypress
 LPARAMETERS nKeyCode, nShiftAltCtrl
 if nkeycode=27
 thisform.release
 endi
 endproc


ENDDEFINE
*
*-- EndDefine: ythemed


*system container class of the form
DEFINE CLASS ysys AS container
Anchor = 768
Top = 3
Left = 591
Width = 85
Height = 24
BackStyle = 0
BorderWidth = 0
Name = "ysys"

ADD OBJECT label1 AS label WITH ;
	AutoSize = .T., ;
	FontBold = .T., ;
	FontSize = 18, ;
	Anchor = 768, ;
	BackStyle = 0, ;
	Caption = "X", ;
	Height = 32, ;
	Left = 62, ;
	MousePointer = 15, ;
	Top = -3, ;
	Width = 18, ;
	ForeColor = RGB(255,0,0), ;
	Name = "Label1"

ADD OBJECT label2 AS label WITH ;
	AutoSize = .T., ;
	FontBold = .T., ;
	FontSize = 20, ;
	Anchor = 768, ;
	BackStyle = 0, ;
	Caption = "-", ;
	Height = 35, ;
	Left = 14, ;
	MousePointer = 15, ;
	Top = -6, ;
	Width = 11, ;
	ForeColor = RGB(255,255,0), ;
	Name = "Label2"

ADD OBJECT label3 AS label WITH ;
	AutoSize = .T., ;
	FontBold = .T., ;
	FontName = "Webdings", ;
	FontSize = 12, ;
	Anchor = 768, ;
	BackStyle = 0, ;
	Caption = "1", ;
	Height = 21, ;
	Left = 33, ;
	MousePointer = 15, ;
	Top = -1, ;
	Width = 19, ;
	ForeColor = RGB(255,255,0), ;
	Name = "Label3"

PROCEDURE Init
	with this
	for i=1 to .controlcount
	.controls(i).mousepointer=15
	bindevent(.controls(i),"mouseEnter",thisform,"my1")
	bindevent(.controls(i),"mouseLeave",thisform,"my2")
	endfor
	endwith
ENDPROC

PROCEDURE label1.Click
	thisform.release
ENDPROC

PROCEDURE label2.Click
	thisform.windowstate=1
ENDPROC

PROCEDURE label3.Click
	thisform.windowstate=iif(thisform.windowstate=0,2,0)
	this.caption=iif(thisform.windowstate=2,"2","1")
ENDPROC

ENDDEFINE
*
*-- EndDefine: ysys

images encoded are built from css gradients buttons.(see previous posts).

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

*6* created on tuesday 17 of may 2017
*this code builds a special menu with ycommand class
*there is 6 styles can be applied dynamically(property ybutton1 is set to ybutton_assign).
*this gives the hability to modify a class property dynamically(see access & assign class methods in help).
*each button can fire a custom code(play with dodefault() at the code top and write your custom code in 'my' method)

set defa to addbs(justpath(sys(16,1)))
*downloads icons & images for making this code working as well.
local m.ydownl
m.ydownl=.t.  && make it false since images downloaded
if m.ydownl=.t.
*download some pngs used in code (8)
*the code downloads first working image from my blog (or point later on the form to any image on disc)
Declare Integer Sleep In kernel32 Integer
Declare Integer URLDownloadToFile In urlmon.Dll Integer pCaller, String szURL, String szFileName, Integer dwReserved, Integer lpfnCB
Declare Integer DeleteUrlCacheEntry In wininet String lpszUrlName

for i=1 to 18
do case
case i=1
lcDownloadURL = "http://img.over-blog-kiwi.com/1/43/54/07/20170517/ob_b79e70_black.PNG"
lcDownloadLoc ="black.png"
case i=2
lcDownloadURL = "http://img.over-blog-kiwi.com/1/43/54/07/20170517/ob_0865b2_black0.PNG"
lcDownloadLoc ="black0.png"
case i=3
lcDownloadURL = "http://img.over-blog-kiwi.com/1/43/54/07/20170517/ob_1573b8_black1.png"
lcDownloadLoc ="black1.png"
case i=4
lcDownloadURL = "http://img.over-blog-kiwi.com/1/43/54/07/20170517/ob_c9c8df_edit-find-32.png"
lcDownloadLoc ="edit_find_32.png"
case i=5
lcDownloadURL = "http://img.over-blog-kiwi.com/1/43/54/07/20170517/ob_f30029_edit-paste-32.png"
lcDownloadLoc ="edit_paste_32.png"
case i=6
lcDownloadURL = "http://img.over-blog-kiwi.com/1/43/54/07/20170517/ob_11bbfd_file-faxservice-32.png"
lcDownloadLoc ="file_faxservice_32.png"
case i=7
lcDownloadURL = "http://img.over-blog-kiwi.com/1/43/54/07/20170517/ob_ce6dbd_file-new-32.png"
lcDownloadLoc ="file_new_32.png"
case i=8
lcDownloadURL = "http://img.over-blog-kiwi.com/1/43/54/07/20170517/ob_2f8cec_file-open-32.png"
lcDownloadLoc ="file_open_32.png"
case i=9
lcDownloadURL = "http://img.over-blog-kiwi.com/1/43/54/07/20170517/ob_d9e2cf_file-prepare-32.png"
lcDownloadLoc ="file_prepare_32.png"
case i=10
lcDownloadURL = "http://img.over-blog-kiwi.com/1/43/54/07/20170517/ob_5b9d9f_file-print-32.png"
lcDownloadLoc ="file_print_32.png"
case i=11
lcDownloadURL = "http://img.over-blog-kiwi.com/1/43/54/07/20170517/ob_169ae9_file-printpreview-32.png"
lcDownloadLoc ="file_printpreview_32.png"
case i=12
lcDownloadURL = "http://img.over-blog-kiwi.com/1/43/54/07/20170517/ob_a65979_file-save-32.png"
lcDownloadLoc ="file_save_32.png"
case i=13
lcDownloadURL = "http://img.over-blog-kiwi.com/1/43/54/07/20170517/ob_b19123_file-saveas-32.png"
lcDownloadLoc ="file_saveas_32.png"
case i=14
lcDownloadURL = "http://img.over-blog-kiwi.com/1/43/54/07/20170517/ob_d7de4d_file-sendmail-32.png"
lcDownloadLoc ="file_sendmail_32.png"
case i=15
lcDownloadURL = "http://img.over-blog-kiwi.com/1/43/54/07/20170517/ob_52a18d_fox.gif"
lcDownloadLoc ="fox.gif"
case i=16
lcDownloadURL = "http://img.over-blog-kiwi.com/1/43/54/07/20170517/ob_83f506_redgrad.PNG"
lcDownloadLoc ="redGrad.png"
case i=17
lcDownloadURL = "http://img.over-blog-kiwi.com/1/43/54/07/20170517/ob_e3c413_ybutton.png"
lcDownloadLoc ="ybutton.png"

case i=18
lcDownloadURL = "http://img.over-blog-kiwi.com/1/43/54/07/20170517/ob_f2372b_zbutton.png"
lcDownloadLoc ="zbutton.png"

endcase

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

_screen.windowstate=1
publi yform
yform=newObject("yrmenu")
yform.show
read events
retu
*
DEFINE CLASS yrmenu AS form
	Height = 546
	Width = 872
	ShowWindow = 2
	AutoCenter = .T.
  backcolor=rgb(12,12,12)
	Caption = "containers classes as menu"
	Name = "Form1"

	ADD OBJECT container1 AS container WITH ;
		Anchor = 0, ;
		Top = -12, ;
		Left = 0, ;
		Width = 160 , ;
		Height = 540, ;
		BackStyle = 0, ;
		BorderWidth = 0, ;
		SpecialEffect = 1, ;
    backcolor=rgb(12,12,12), ;
		Name = "Container1"
    
  ADD OBject yim as image with;
	anchor=15,;
	left=165,;
	top=0,;
	picture="",;
	name="yim"   

	ADD OBJECT optiongroup1 AS optiongroup WITH ;
		AutoSize = .T., ;
		ButtonCount = 6, ;
		BackStyle = 0, ;
		BorderStyle = 0, ;
		Value = 1, ;
		Height = 27, ;
		Left = 276, ;
		Top = 24, ;
		Width = 126, ;
		Name = "Optiongroup1", ;
		Option1.Caption = "", ;
		Option1.Value = 1, ;
		Option1.Height = 17, ;
		Option1.Left = 5, ;
		Option1.Style = 0, ;
		Option1.Top = 5, ;
		Option1.Width = 18, ;
		Option1.AutoSize = .F., ;
		Option1.Name = "Option1", ;
		Option2.Caption = "", ;
		Option2.Height = 17, ;
		Option2.Left = 25, ;
		Option2.Style = 0, ;
		Option2.Top = 5, ;
		Option2.Width = 18, ;
		Option2.AutoSize = .F., ;
		Option2.Name = "Option2", ;
		Option3.Caption = "", ;
		Option3.Height = 17, ;
		Option3.Left = 45, ;
		Option3.Style = 0, ;
		Option3.Top = 5, ;
		Option3.Width = 18, ;
		Option3.AutoSize = .F., ;
		Option3.Name = "Option3", ;
		Option4.Caption = "", ;
		Option4.Height = 17, ;
		Option4.Left = 65, ;
		Option4.Style = 0, ;
		Option4.Top = 5, ;
		Option4.Width = 18, ;
		Option4.AutoSize = .F., ;
		Option4.Name = "Option4", ;
		Option5.Caption = "", ;
		Option5.Height = 17, ;
		Option5.Left = 85, ;
		Option5.Style = 0, ;
		Option5.Top = 5, ;
		Option5.Width = 18, ;
		Option5.AutoSize = .F., ;
		Option5.Name = "Option5", ;
		Option6.Caption = "", ;
		Option6.Height = 17, ;
		Option6.Left = 103, ;
		Option6.Top = 5, ;
		Option6.Width = 18, ;
		Option6.AutoSize = .T., ;
		Option6.Name = "Option6"


	ADD OBJECT label1 AS label WITH ;
		AutoSize = .T., ;
		FontBold = .T., ;
		FontSize = 12, ;
		BackStyle = 0, ;
		Caption = "6 styles", ;
		Height = 22, ;
		Left = 293, ;
		Top = 4, ;
		Width = 60, ;
		ForeColor = RGB(255,0,0), ;
		Name = "Label1"

	PROCEDURE Destroy
		clea events
	ENDPROC

	PROCEDURE container1.Init
		with  this
		.top=0
		.left=0
		 for i=1 to 12
		 .addobject("ycommand"+trans(i),"ycommand")
		 with  eval(".ycommand"+trans(i))
		.label1.caption="Item"+trans(i)
		.width=150
		.height=40
		.left=5
		if i=1
		.top=10
		else
		.top=this.controls(i-1).top+this.controls(i-1).height+0  &&+0 :can be positif or negatif to adjust buttons
		endi
		.name="ycommand"+trans(i)
		do case
		case i=1
		.image2.picture="fox.gif"
		case i=2
		.image2.picture="File_Print_32.png"
		case i=3
		.image2.picture="File_PrintPreview_32.png"
		case i=4
		.image2.picture="File_Save_32.png"
		case i=5
		.image2.picture="File_SendMail_32.png"
		case i=6
		.image2.picture="File_Prepare_32.png"
		case i=7
		.image2.picture="Edit_Paste_32.png"
		case i=8
	   .image2.picture="file_new_32.png"
		case i=9
		.image2.picture="File_Print_32.png"
		case i=10
		.image2.picture="File_SaveAs_32.png"
		case i=11
		.image2.picture="File_FaxService_32.png"
		case i=12
		.image2.picture="file_save_32.png"
		endcase
		.visible=.t.
		endwith
		endfor
		endwith
	ENDPROC

	PROCEDURE optiongroup1.Init
		with this
		.setall("mousepointer",15,"optionbutton")
		endwith
	ENDPROC

	PROCEDURE optiongroup1.Click
		with thisform.container1
		dodefault()

		do case
		case this.value=1
		local m.myvar1
		text to m.myvar1 noshow
		iVBORw0KGgoAAAANSUhEUgAAAGgAAAASCAIAAAA4xwxRAAAAAXNSR0IArs4c6QAAAARnQU1BAACxjwv8YQUAAAAJcEhZcwAADsMAAA7DAcdvqGQAAAB6SURBVFhH7djLCcJgAAThf/pvQhBBEBE1GCIhB2+K4jNKxF60Bvc8Xwlz22X3+Rb9j+5tuATtYLgEzctwCTa94RKsH4ZLsLwZLsFob7gE44PhEkyOhkswPRkuwexsuATzi+ESLK6GS7C6Gy5B5XKIUD8Nl2DrOxIo5QcWJy1PlSw2ZAAAAABJRU5ErkJggg==
		endtext
		.setall("ybutton1",strconv(m.myvar1,14),"ycommand")  &&default
		.setall("forecolor",0,"label")

		case this.value=2
		.setall("ybutton1",filetostr("black1.png"),"ycommand")
		.setall("forecolor",rgb(0,0,0),"label")

		case this.value=3
		.setall("ybutton1",filetostr("RedGrad.png"),"ycommand")
		.setall("forecolor",rgb(25,25,255),"label")
	
		case this.value=4
		.setall("ybutton1",filetostr("black0.png"),"ycommand")
       .setall("forecolor",rgb(0,255,0),"label")

		case this.value=5
		.setall("ybutton1",filetostr("zbutton.png"),"ycommand")
        .setall("forecolor",rgb(100,25,205),"label")

		case this.value=6
		.setall("ybutton1",filetostr("ybutton.png"),"ycommand")
        .setall("forecolor",rgb(45,0,22),"label")
		endcase
		
		.refresh
		dodefault()
		endwith
	ENDPROC
  
  procedure yim.init
	with this
	.anchor=15
	.left=.parent.container1.left+.parent.container1.width
	.top=0
	.width=.parent.width-.parent.container1.left-.parent.container1.width
	.height=.parent.height
	.zorder(1)
	.stretch=2
	.PictureVal=yloadImg("http://i39.servimg.com/u/f39/15/54/62/74/untitl37.jpg")
	endwith
endproc

ENDDEFINE
*
*-- EndDefine: yrmenu
*

DEFINE CLASS ycommand AS container
	Width = 139
	Height = 40
	ybutton1 = .F.
	ybutton2 = .F.
	yforecolor=0
	Name = "ycommand"

	ADD OBJECT label1 AS label WITH ;
		Alignment = 0, ;
		Caption = "Label1", ;
		Height = 25, ;
		Left = 36, ;
		Top = 8, ;
		Width = 96, ;
		Name = "Label1"

	ADD OBJECT image1 AS image WITH ;
		Height = 37, ;
		Left = 3, ;
		Top = 3, ;
		Width = 133, ;
		Name = "Image1"

	ADD OBJECT image2 AS image WITH ;
		Picture = "fox.gif", ;
		Stretch = 0, ;
		Height = 32, ;
		Left = 0, ;
		Top = 0, ;
		Width = 32, ;
		Name = "Image2"

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

	PROCEDURE ybutton1_assign
		LPARAMETERS vNewVal
		*To do: Modify this routine for the Assign method
		THIS.ybutton1 = m.vNewVal
		this.image1.pictureVal=this.ybutton1
	ENDPROC

	PROCEDURE Init
		local m.myvar1,m.myvar2
		text to m.myvar1 noshow
		iVBORw0KGgoAAAANSUhEUgAAAGgAAAASCAIAAAA4xwxRAAAAAXNSR0IArs4c6QAAAARnQU1BAACxjwv8YQUAAAAJcEhZcwAADsMAAA7DAcdvqGQAAAB6SURBVFhH7djLCcJgAAThf/pvQhBBEBE1GCIhB2+K4jNKxF60Bvc8Xwlz22X3+Rb9j+5tuATtYLgEzctwCTa94RKsH4ZLsLwZLsFob7gE44PhEkyOhkswPRkuwexsuATzi+ESLK6GS7C6Gy5B5XKIUD8Nl2DrOxIo5QcWJy1PlSw2ZAAAAABJRU5ErkJggg==
		endtext
		text to m.myvar2 noshow
		iVBORw0KGgoAAAANSUhEUgAAAGcAAAASCAIAAADJzFfcAAAAAXNSR0IArs4c6QAAAARnQU1BAACxjwv8YQUAAAAJcEhZcwAADsMAAA7DAcdvqGQAAAB2SURBVFhH7cKhCsIAAEXR95XGVavZumizrBgsgnksGv0BmyADQUTUMdkQg+XtG25/hyP/T0nLv2PS8veQtDzUScv9Lmn5vUlafq6Tls+zpOVLkbTczpOWr4uk5dsyafleJi0/VknLryppudsmLX/2Sctjk+zYTLBOC5DrQFA2AAAAAElFTkSuQmCC
		endtext
		this.ybutton1=strconv(m.myvar1,14)
		this.ybutton2=strconv(m.myvar2,14)

		with this
		.backstyle=0
		.borderwidth=0

		with .image1
		.mousepointer=15
		.stretch=2
		.anchor=15
		.left=0
		.top=0
		.width=.parent.width
		.height=.parent.height
		.zorder(1)
		.pictureVal=this.ybutton1
		endwith
		
		with .image2
		.stretch=0
		.left=0
		.top=0
		.width=32
		.height=32
		.zorder(0)
		endwith

		with .label1
		.fontbold=.t.
		.fontsize=10
		.mousepointer=15
		.backstyle=0
		.autosize=.t.
		.left=.parent.image2.left+.parent.image2.width+5
		.top =(.parent.height-.height)/2
		.alignment=0
		endwith

		bindevent(.image1,"mousedown",this,"my")
		bindevent(.label1,"mousedown",this,"my")

		endwith
	ENDPROC

	PROCEDURE label1.Init
		with this
		.fontbold=.t.
		.fontsize=10
		.mousepointer=15
		.backstyle=0
		.autosize=.t.
		.top =(.parent.height-.height)/2
		.alignment=0
		endwith
	ENDPROC

	PROCEDURE label1.MouseLeave
		LPARAMETERS nButton, nShift, nXCoord, nYCoord
		this.forecolor=this.parent.yforecolor
		this.parent.image1.pictureVal=this.parent.ybutton1
		this.parent.borderwidth=0
	ENDPROC

	PROCEDURE label1.MouseEnter
		LPARAMETERS nButton, nShift, nXCoord, nYCoord
		 this.parent.yforecolor=this.forecolor
		this.forecolor=255
		this.parent.image1.pictureVal=this.parent.ybutton2
		this.parent.borderwidth=1
	ENDPROC	

	PROCEDURE image1.MouseLeave
		LPARAMETERS nButton, nShift, nXCoord, nYCoord
		this.pictureVal=this.parent.ybutton1
		this.parent.borderwidth=0
	ENDPROC

	PROCEDURE image1.MouseEnter
		LPARAMETERS nButton, nShift, nXCoord, nYCoord
		this.pictureVal=this.parent.ybutton2
		this.parent.borderwidth=1
	ENDPROC

	PROCEDURE image1.Init
		with this
		.anchor=15
		.left=0
		.top=0
		.width=.parent.width
		.height=.parent.height
		.zorder(1)
		endwith
	ENDPROC
	
	PROCEDURE image2.Init
		with this
		.anchor=15
		.left=0
		.top=0
		.width=32
		.height=32
		.stretch=0
		.zorder(0)
		endwith
	ENDPROC
ENDDEFINE
*
*-- EndDefine: ycommand

Function yloadImg
Lparameters lcURL
Local loRequest
m.loRequest = Createobject('MsXml2.XmlHttp')
m.loRequest.Open("GET",lcURL,.F.)
m.loRequest.Send()
local m.x
m.x=m.loRequest.ResponseBody
m.loRequest=Null
Return m.x
Endfunc

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

*7* created on tuesday 17 of may 2017
*this code builds a special menu with ybutton_shape class (can translate to visual class vcx easily)
*this uses a more simple class button with (container+shape+label+icon)
*it does same goal as previous code.
*the new button class (ybutton_shape) uses the method ybackcolor_assign a,d yforecor_assign to permit changing dynamically these properties.
*Can adjust the shape curvature in class code.(here value=10 is suffisent).
*can collapse/expand the container of special buttons.

Publi oform
oform=Newobject("ybuttons")
oform.Show
Read Events
Return
*
Define Class ybuttons As Form
Height = 611
Width = 889
ShowWindow = 2
AutoCenter = .T.
Caption = "ANother simple special menu with ybutton_shape class"
BackColor = Rgb(0,0,0)
Name = "Form1"

Add Object container1 As Container With ;
	Top = 5, ;
	Left = 0, ;
	Width = 168, ;
	Height = 600, ;
	BackStyle = 0, ;
	Name = "Container1"

Add Object image1 As Image With ;
	Anchor = 15, ;
	Height = 600, ;
	Left = 180, ;
	Top = 0, ;
	Width = 697, ;
	Name = "Image1"

Procedure container1.Init
DoDefault()
With  This
	.Top=0
	.Left=0
	For i=1 To 12
		.AddObject("ybutton_shape"+Trans(i),"ybutton_shape")
		With  Eval(".ybutton_shape"+Trans(i))
			.label1.Caption="this is Item"+Trans(i)
			.Width=150
			.Height=40
			.Left=5
			If i=1
				.Top=10
			Else
				.Top=This.Controls(i-1).Top+This.Controls(i-1).Height+0  &&+0 :can be positif or negatif to adjust buttons
			Endi
			.Name="ybutton_shape"+Trans(i)
			Do Case
			Case i=1
				.image1.Picture="fox.gif"
			Case i=2
				.image1.Picture="File_Print_32.png"
			Case i=3
				.image1.Picture="File_PrintPreview_32.png"
			Case i=4
				.image1.Picture="File_Save_32.png"
			Case i=5
				.image1.Picture="File_SendMail_32.png"
			Case i=6
				.image1.Picture="File_Prepare_32.png"
			Case i=7
				.image1.Picture="Edit_Paste_32.png"
			Case i=8
				.image1.Picture="file_new_32.png"
			Case i=9
				.image1.Picture="File_Print_32.png"
			Case i=10
				.image1.Picture="File_SaveAs_32.png"
			Case i=11
				.image1.Picture="File_FaxService_32.png"
			Case i=12
				.image1.Picture="file_save_32.png"
			Endcase
			.Visible=.T.
		Endwith
	Endfor

	.AddObject("command1","ycommand1")
	With .command1
		.Top = 552
		.Left = 11
		.Height = 27
		.Width = 72
		.Caption = "Backcolor"
		.MousePointer = 15
		.BackColor = Rgb(128,255,0)
		.Name = "Command1"
		.Visible=.T.
	Endwith

	.AddObject("command2","ycommand2")
	With .command2
		.Top = 552
		.Left = 86
		.Height = 27
		.Width = 70
		.Caption = "Forecolor"
		.MousePointer = 15
		.BackColor = Rgb(128,255,0)
		.Name = "Command2"
		.Visible=.T.
	Endwith
  
.AddObject("ylab1","ylab")
	with .ylab1
	.top=574
	.left=138
	.height=27
	.width=40
	.caption="7"
	.fontname="webdings"
	.fontsize=18
	.backstyle=0
	.forecolor=rgb(0,255,0)
	.name="ylab1"
	.visible=.t.
	endwith
  
Endwith
Endproc

Procedure yloadimg
Lparameters lcURL
Local loRequest
m.loRequest = Createobject('MsXml2.XmlHttp')
m.loRequest.Open("GET",lcURL,.F.)
m.loRequest.Send()
Local m.x
m.x=m.loRequest.ResponseBody
m.loRequest=Null
Return m.x
Endproc

Procedure Destroy
yform=Null
Release yform
Clea Events
Endproc

Procedure Init
Set Defa To Addbs(Justpath(Sys(16,1)))
*downloads icons & images for making this code working as well.
Local m.ydownl
m.ydownl=.T.  && make it false since images downloaded
If m.ydownl=.T.
	*download some pngs used in code (12)
	*the code downloads first working image from my blog (or point later on the form to any image on disc)
	Declare Integer Sleep In kernel32 Integer
	Declare Integer URLDownloadToFile In urlmon.Dll Integer pCaller, String szURL, String szFileName, Integer dwReserved, Integer lpfnCB
	Declare Integer DeleteUrlCacheEntry In wininet String lpszUrlName

	For i=1 To 14
		Do Case
		Case i=1
			lcDownloadURL = "http://img.over-blog-kiwi.com/1/43/54/07/20170517/ob_c9c8df_edit-find-32.png"
			lcDownloadLoc ="edit_find_32.png"

		Case i=2
			lcDownloadURL = "http://img.over-blog-kiwi.com/1/43/54/07/20170517/ob_f30029_edit-paste-32.png"
			lcDownloadLoc ="edit_paste_32.png"

		Case i=3
			lcDownloadURL = "http://img.over-blog-kiwi.com/1/43/54/07/20170517/ob_11bbfd_file-faxservice-32.png"
			lcDownloadLoc ="file_faxservice_32.png"

		Case i=4
			lcDownloadURL = "http://img.over-blog-kiwi.com/1/43/54/07/20170517/ob_ce6dbd_file-new-32.png"
			lcDownloadLoc ="file_new_32.png"

		Case i=5
			lcDownloadURL = "http://img.over-blog-kiwi.com/1/43/54/07/20170517/ob_2f8cec_file-open-32.png"
			lcDownloadLoc ="file_open_32.png"

		Case i=6
			lcDownloadURL = "http://img.over-blog-kiwi.com/1/43/54/07/20170517/ob_d9e2cf_file-prepare-32.png"
			lcDownloadLoc ="file_prepare_32.png"

		Case i=7
			lcDownloadURL = "http://img.over-blog-kiwi.com/1/43/54/07/20170517/ob_5b9d9f_file-print-32.png"
			lcDownloadLoc ="file_print_32.png"

		Case i=8
			lcDownloadURL = "http://img.over-blog-kiwi.com/1/43/54/07/20170517/ob_169ae9_file-printpreview-32.png"
			lcDownloadLoc ="file_printpreview_32.png"

		Case i=9
			lcDownloadURL = "http://img.over-blog-kiwi.com/1/43/54/07/20170517/ob_a65979_file-save-32.png"
			lcDownloadLoc ="file_save_32.png"

		Case i=10
			lcDownloadURL = "http://img.over-blog-kiwi.com/1/43/54/07/20170517/ob_b19123_file-saveas-32.png"
			lcDownloadLoc ="file_saveas_32.png"

		Case i=11
			lcDownloadURL = "http://img.over-blog-kiwi.com/1/43/54/07/20170517/ob_d7de4d_file-sendmail-32.png"
			lcDownloadLoc ="file_sendmail_32.png"

		Case i=12
			lcDownloadURL = "http://img.over-blog-kiwi.com/1/43/54/07/20170517/ob_52a18d_fox.gif"
			lcDownloadLoc ="fox.gif"

		Endcase

		lnResult = DeleteUrlCacheEntry(lcDownloadURL)
		lnResult = URLDownloadToFile(0, lcDownloadURL, lcDownloadLoc , 0,0)
		If lnResult = 0
			Wait Window "Download "+lcDownloadLoc +"  Complete" Nowait
			*Else
			*!*  Messagebox("Download fails")
		Endi
	Endfor
Endi
_Screen.WindowState=1
DoDefault()
Endproc

Procedure image1.Init
With This
	.Anchor=15
	.Left=.Parent.container1.Left+.Parent.container1.Width
	.Top=0
	.Width=.Parent.Width-.Parent.container1.Left-.Parent.container1.Width
	.Height=.Parent.Height
	.ZOrder(1)
	.Stretch=2
	.PictureVal=Thisform.yloadimg("https://s-media-cache-ak0.pinimg.com/originals/87/f8/14/87f81427fe10439d1484330f0265f35b.jpg")
Endwith

Procedure yactions   &&write actions to do here
Lparameters N

Do Case
Case N=1
	Run/N notepad
Case N=2
	Run/N mspaint
	*
	*case n=3
	*
	*case n=14
	**********
Otherwise
	Messagebox(loObject.Parent.Name+" clicked...can write some code from method my.",0+32+4096,'',1100)
Endcase
Endproc

Enddefine
*
*-- EndDefine: ybuttons

*
Define Class ybutton_shape As Container
Width = 145
Height = 35
BackStyle = 0
BorderWidth = 0
ybackcolor =RGB(242,97,0)     &&Rgb(202,213,169)
yforecolor = .F.
Name = "ybutton_shape"

Add Object shape1 As Shape With ;
	Top = 0, ;
	Left = 3, ;
	Height = 35, ;
	Width = 139, ;
	BackStyle = 1, ;
	BorderStyle = 1, ;
	BorderWidth = 1, ;
	Curvature = 15, ;
	BackColor = Rgb(202,213,169), ;
	Name = "Shape1"

Add Object label1 As Label With ;
	AutoSize = .T., ;
	FontBold = .T., ;
	FontSize = 10, ;
	BackStyle = 0, ;
	Caption = "myButton", ;
	Height = 18, ;
	Left = 36, ;
	MousePointer = 15, ;
	Top = 5, ;
	Width = 62, ;
	Name = "Label1"

Add Object image1 As Image With ;
	Picture = "copy24.png", ;
	Stretch = 2, ;
	Height = 25, ;
	Left = 8, ;
	Top = 5, ;
	Width = 25, ;
	Name = "Image1"

Procedure my
Lparameters nButton, nShift, nXCoord, nYCoord
*--- aevent create an array laEvents
Aevents( myArray, 0)
*--- reference the calling object
loObject = myArray[1]
N=Int(Val(Substr(loObject.Parent.Name,14)))
Thisform.yactions(N)
Endproc

Procedure ybackcolor_assign
Lparameters vNewVal
*To do: Modify this routine for the Assign method
This.shape1.BackColor=m.vNewVal
This.ybackcolor = m.vNewVal
Endproc

Procedure yforecolor_assign
Lparameters vNewVal
*To do: Modify this routine for the Assign method
This.yforecolor = m.vNewVal
This.label1.ForeColor=m.vNewVal
Endproc

Procedure Init
This.ybackcolor=RGB(242,97,0)     &&Rgb(202,213,169)
This.yforecolor=0

Bindevent(This.shape1,"mousedown",This,"my")
Bindevent(This.label1,"mousedown",This,"my")
Bindevent(This.image1,"mousedown",This,"my")
Endproc

Procedure MouseEnter
Lparameters nButton, nShift, nXCoord, nYCoord
This.shape1.MouseEnter(1)
Endproc

Procedure MouseLeave
Lparameters nButton, nShift, nXCoord, nYCoord
This.shape1.MouseLeave(1)
Endproc

Procedure shape1.MouseLeave
Lparameters nButton, nShift, nXCoord, nYCoord
This.BorderWidth=1
This.BackColor=This.Parent.ybackcolor
Endproc

Procedure shape1.MouseEnter
Lparameters nButton, nShift, nXCoord, nYCoord

With This.Parent
	For i=1 To .ControlCount
		If Lower(.Controls(i).Class)=="ybutton_shape"
			Try
				.Controls(i).shape1.MouseLeave(1)
			Catch
			Endtry
		Endi
	Endfor
Endwith

With This
	.BackStyle=1
	.BorderWidth=2
	*.parent.ybackcolor=.backcolor
	.BackColor=Rgb(254,216,112)  &&new color
Endwith
Endproc

Procedure shape1.Init
With This
	.Anchor=15
	.Left=0
	.Top=0
	.Width=.Parent.Width
	.Height=.Parent.Height
	.BackStyle=1
	.BackColor=Rgb(202,213,169)
	.Parent.ybackcolor=.BackColor
	BorderWidth=1
	.Curvature=10
	.ZOrder(1)
Endwith
Endproc

Procedure label1.MouseEnter
Lparameters nButton, nShift, nXCoord, nYCoord
This.ForeColor=255
This.Parent.shape1.MouseEnter(1)
Endproc

Procedure label1.MouseLeave
Lparameters nButton, nShift, nXCoord, nYCoord
This.ForeColor=This.Parent.yforecolor
Endproc

Procedure label1.Init
This.Parent.yforecolor=This.ForeColor
Endproc

Enddefine
*
*-- EndDefine: ybutton_shape


*
Define Class ycommand1 As CommandButton
Procedure Click
Local m.xcolor
m.xcolor=Getcolor()
If m.xcolor=-1
	Return .F.
Endi
With This.Parent
	DoDefault()
	For i=1 To .ControlCount
		If Lower(.Controls(i).Class)=="ybutton_shape"
			.Controls(i).ybackcolor=m.xcolor
		Endi
	Endfor
Endwith
Endproc
Enddefine

*
Define Class ycommand2 As CommandButton
Procedure Click
Local m.xcolor
m.xcolor=Getcolor()
If m.xcolor=-1
	Return .F.
Endi
With This.Parent
	DoDefault()
	For i=1 To .ControlCount
		If Lower(.Controls(i).Class)=="ybutton_shape"
			.Controls(i).yforecolor=m.xcolor
		Endi
	Endfor
Endwith
Endproc
Enddefine


Define Class ylab As label
mousepointer=15
ycl=0
Procedure Click
this.ycl=iif(this.ycl=1,0,1)
with this
if .ycl=1
.caption="8"
thisform.container1.left=-thisform.container1.width+30
else
.caption="7"
.parent.left=5
endi
thisform.image1.left=thisform.container1.left+thisform.container1.width
thisform.image1.width=thisform.width-thisform.image1.left
Endwith
Endproc
Enddefine

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

Comments

[Irwin]

Excellent..! I love VFP Ribbons...!

Thanks Yousfi..!