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.