Working on VFP objects dynamically - part3
this is a top level form with resizing all inner controls.
Anchoring dont suffisent to do the perfect resizing.this add a class (from Marcia Akins) to resize each object contained on form and preserve some ratio.it needed with large screens.
there is another class adding a shape behind each control at mouseEnter making some shadow color.the shape is destroyed with mouseLeave event.
click on each option in optionGroup control to reach some web images dynamically (avoiding disc) with the pictureVal image control property (all is in memory).
Note: of course can convert the resizing class below to visual custom class and drop it onto any form as embed class.
for converting any prg class to a visual vcx class can use this Tom Rettig utility:
http://fox.wikis.com/wc.dll?Wiki~PrgToVcx
-addded a similar lightbox on form with random color.
[Post 228]
Click on code to select [then copy] -click outside to deselect
*1*
_screen.windowState=1
close data all
*create web urls to link to some web images.
create cursor yhm (yimage c(200))
insert into yhm values("https://lh3.googleusercontent.com/F2wrS38HmZz5hmKl7fWKbgx5xnVmwbCj-8cNbOd3JqnKj2y9kKVwK3N4ncaHr7R4VXrAtzmqwFbA5FM4q1hG6_ClLOoMuhCq=w293-h220")
insert into yhm values("https://lh3.googleusercontent.com/OtT3A1-Z7ljqlnVdFc20gHl_Fp37qmhwu0N_gFYajzS6wQ_0393FFA6bbQ76Dsrq4sG2GWrfqzfujOpFnE1g4v65W6n2rVJb=w293-h220")
insert into yhm values("https://lh3.googleusercontent.com/yvBTsFA9q2Ahxv6QT24CWzYuisyk_G9zAmzDH3Tv5WPKbL9WCyYPgmafl-pnP2Ccz8iLmGHSdrD_FWKIdZFqxHhIo1fwMujG=w293-h220")
insert into yhm values("https://lh3.googleusercontent.com/UA9TO-BnbRXfSLNvfDB--VRR6t9-zYukvIxXqwfs1tBdqO8jK4PKmZ9rwFhZdcsF6X05nq-6tPFF9rPhb59HPbeuJggW677s=w293-h220")
insert into yhm values("https://lh3.googleusercontent.com/eWp1G7UtJLHkgAm4rRWKLCY3uPoa8S9L-UJ6GIrVdLcDld-SZSJc2LHwzJbHLGKNWzajV7OwQVffA9654DmhxMPy2aEeUBBK=w293-h220")
insert into yhm values("https://lh3.googleusercontent.com/YzL0sxgqjh0fPHiXADB_-7Y8d1BvC5AGAN6Qk6W3ytvFJrB0Hfjq2y_2kpxpl5A6BzaK7tLiHjdoClFzmuC9x7INfKSHkiYN=w293-h220")
insert into yhm values("https://lh3.googleusercontent.com/oeVq3QdGMiD44xvfuU80yvnTN0AoJPfMok47bjYHsjOADrNOQC3hCjC6Jd5zSr1CZl3cQvijK1xxk72jOFJYYBi0IYnZYqYo=w293-h220")
insert into yhm values("https://lh3.googleusercontent.com/c5q_4_7dUZ0zbmTF_QtWIvgoCHNxKvguT3SGDBQ3lkl9Z6ZwtOyW3JParpyZbrEjpnQO1jahmwpV9fnA1hlh9tZdb5wBaKzP=w293-h220")
sele yhm
locate
Publi yform
yform=Newobject("asup")
yform.Show
Read Events
retu
*
Define Class asup As Form
Height = 497
Width = 897
ShowWindow = 2
AutoCenter = .T.
Caption = "Rezizer class-dynamic effects on form"
BackColor = Rgb(212,210,208)
Name = "Form1"
Add Object yhelp As Label With ;
Anchor=0,;
AutoSize = .T., ;
FontBold = .T., ;
FontSize = 32, ;
BackStyle = 0, ;
Caption = "?", ;
Height = 54, ;
Left = 855, ;
Top = 2, ;
Width = 20, ;
forecolor=rgb(0,255,0),;
mousepointer=15,;
Name = "yhelp"
Add Object label1 As Label With ;
AutoSize = .T., ;
FontBold = .T., ;
FontSize = 32, ;
BackStyle = 0, ;
Caption = "Hello World", ;
Height = 54, ;
Left = 10, ;
Top = 26, ;
Width = 239, ;
Name = "Label1"
Add Object command1 As CommandButton With ;
Top = 204, ;
Left = 12, ;
Height = 49, ;
Width = 193, ;
Caption = "Command1", ;
Name = "Command1"
Add Object image1 As Image With ;
Picture = "..\..\_____100photos\hammam ouarka g+\sam_3227_resized.jpg", ;
Stretch = 2, ;
Height = 157, ;
Left = 324, ;
Top = 48, ;
Width = 252, ;
Name = "Image1"
Add Object container1 As ycont With ;
Top = 264, ;
Left = 9, ;
Width = 432, ;
Height = 157, ;
Name = "Container1"
Add Object optiongroup1 As OptionGroup With ;
AutoSize = .T., ;
ButtonCount = 5, ;
BackStyle = 0, ;
Value = 1, ;
Height = 27, ;
Left = 264, ;
Top = 2, ;
Width = 323, ;
Name = "Optiongroup1", ;
Option1.Caption = "Option1", ;
Option1.Value = 1, ;
Option1.Height = 17, ;
Option1.Left = 5, ;
Option1.Style = 0, ;
Option1.Top = 5, ;
Option1.Width = 61, ;
Option1.AutoSize = .F., ;
Option1.Name = "Option1", ;
Option2.Caption = "Option2", ;
Option2.Height = 17, ;
Option2.Left = 68, ;
Option2.Style = 0, ;
Option2.Top = 5, ;
Option2.Width = 61, ;
Option2.AutoSize = .F., ;
Option2.Name = "Option2", ;
Option3.Caption = "Option3", ;
Option3.Height = 17, ;
Option3.Left = 131, ;
Option3.Style = 0, ;
Option3.Top = 5, ;
Option3.Width = 61, ;
Option3.AutoSize = .F., ;
Option3.Name = "Option3", ;
Option4.Caption = "Option4", ;
Option4.Height = 17, ;
Option4.Left = 194, ;
Option4.Style = 0, ;
Option4.Top = 5, ;
Option4.Width = 61, ;
Option4.AutoSize = .F., ;
Option4.Name = "Option4", ;
Option5.Caption = "Option5", ;
Option5.Height = 17, ;
Option5.Left = 257, ;
Option5.Style = 0, ;
Option5.Top = 5, ;
Option5.Width = 61, ;
Option5.AutoSize = .F., ;
Option5.Name = "Option5"
Add Object commandgroup1 As CommandGroup With ;
AutoSize = .T., ;
ButtonCount = 4, ;
Value = 1, ;
Height = 124, ;
Left = 216, ;
Top = 120, ;
Width = 94, ;
Name = "Commandgroup1", ;
command1.Top = 5, ;
command1.Left = 5, ;
command1.Height = 27, ;
command1.Width = 84, ;
command1.Caption = "Command1", ;
command1.Name = "Command1", ;
Command2.Top = 34, ;
Command2.Left = 5, ;
Command2.Height = 27, ;
Command2.Width = 84, ;
Command2.Caption = "Command2", ;
Command2.Name = "Command2", ;
Command3.Top = 63, ;
Command3.Left = 5, ;
Command3.Height = 27, ;
Command3.Width = 84, ;
Command3.Caption = "Command3", ;
Command3.Name = "Command3", ;
Command4.Top = 92, ;
Command4.Left = 5, ;
Command4.Height = 27, ;
Command4.Width = 84, ;
Command4.Caption = "Command4", ;
Command4.Name = "Command4"
Add Object grid1 As Grid With ;
Height = 253, ;
Left = 456, ;
Top = 228, ;
Width = 420, ;
Themes = .F., ;
Name = "Grid1"
Add Object list1 As ListBox With ;
Height = 181, ;
Left = 651, ;
Top = 18, ;
Width = 157, ;
Name = "List1"
Add Object label2 As Label With ;
AutoSize = .T., ;
FontBold = .T., ;
FontSize = 32, ;
BackStyle = 0, ;
Caption = "Hello World", ;
Height = 54, ;
Left = 5, ;
Top = 26, ;
Width = 239, ;
ForeColor = Rgb(0,255,0), ;
Name = "Label2"
Add Object combo1 As ComboBox With ;
Height = 25, ;
Left = 12, ;
Top = 120, ;
Width = 157, ;
Name = "Combo1"
procedure yhelp.click
local m.myvar
text to m.myvar pretext 7 noshow
this is a top level form with resizing all inner controls.
Anchoring dont suffisent to do the perfect resizing.this add a class (for Marcia Akins) to resize each
object contained on form and preserve some ratio.it needed with large screens.
there is another class adding a shape behind each control at mouseEnter making some shadow color.the shape
is destroyed with mouseLeave event.
click on each option in optionGroup control to reach some web images dynamically (avoiding disc) with the
pictureVal image control property (all is in memory).
endtext
messagebox(m.myvar,0+32+4096,"summary help")
endproc
Procedure my
Lparameters nButton, nShift, nXCoord, nYCoord
*--- aevent create an array laEvents
Aevents( myArray, 0)
*--- reference the calling object
loObject = myArray[1]
With Thisform
If Vartype(.yshape)="O"
.RemoveObject("yshape")
Endi
.AddObject("yshape","shape")
With .yshape
.Left=loObject.Left-5
.Top=loObject.Top-5
.Width=loObject.Width+10
.Height=loObject.Height+10
.BackColor=Rgb(255*Rand(),255*Rand(),255*Rand())
.ZOrder(1)
.Name="yshape"
.Visible=.T.
Endwith
Endwith
Endproc
Procedure my1
Lparameters nButton, nShift, nXCoord, nYCoord
*--- aevent create an array laEvents
Aevents( myArray, 0)
*--- reference the calling object
loObject = myArray[1]
With Thisform
If Vartype(.yshape)="O"
.RemoveObject("yshape")
Endi
Endwith
Endproc
Procedure my2
Lparameters nButton, nShift, nXCoord, nYCoord
*!* *--- aevent create an array laEvents
*!* Aevents( myArray, 0)
*!* *--- reference the calling object
*!* loObject = myArray[1]
sele yhm
try
skip
catch
locate
endtry
if empty(yimage)
locate
endi
thisform.image1.PictureVal=yloadImg(yimage)
sele yhm
try
skip
catch
locate
endtry
if empty(yimage)
locate
endi
thisform.container1.image1.PictureVal=yloadImg(yimage)
Endproc
Procedure Load
Sele company From Home(1)+"samples\data\customer" Into Cursor ycurs
Sele * From Home(1)+"samples\data\customer" Into Cursor zcurs
Endproc
Procedure Init
With Thisform
.SetAll("mousepointer",15,"commandbutton")
For i=1 To .ControlCount
Bindevent(.Controls(i),"mouseEnter",Thisform,"my")
Bindevent(.Controls(i),"mouseLeave",Thisform,"my1")
Endfor
endwith
with thisform.optionGroup1
.setall("mousepointer",15,"OptionButton")
for i=1 to .buttoncount
bindevent(.buttons(i),"mousedown",thisform,"my2")
endfor
Endwith
*** Add the resizer
This.Newobject( 'Resizer', 'stdResizer')
Return DoDefault()
Endproc
Procedure Resize
This.Resizer.AdjustControls()
Endproc
Procedure Destroy
Clea Events
Endproc
Procedure optiongroup1.Init
This.SetAll("autosize",.T.,"OptionButton")
This.SetAll("fontsize",8,"OptionButton")
This.SetAll("backstyle",0,"OptionButton")
Endproc
Procedure grid1.Init
With This
.RecordSource="zcurs"
.RecordSourceType=1
.DeleteMark=.F.
.GridLines=0
.FontBold=.T.
For i=1 To .ColumnCount
.Columns(i).header1.BackColor=0
.Columns(i).header1.ForeColor=255
.Columns(i).header1.FontSize=12
Endfor
.SetAll("DynamicBackColor", "IIF(MOD(RECNO( ), 2)=0, RGB(145,55,105) , RGB(100,175,40))", "Column")
Sele zcurs
Locate
.Refresh
Endwith
Endproc
Procedure list1.Init
With This
.RowSource="ycurs"
.RowSourceType=6
Sele ycurs
Locate
.ListIndex=1
.SelectedItemBackColor=Rgb(70,60,50)
.SelectedItemForeColor=Rgb(10,191,160)
.SpecialEffect=1
.FontSize=8
.ItemBackColor=Rgb(40,40,40)
.ItemForeColor=Rgb(255,204,153)
.BorderColor=Rgb(235,132,0)
.ItemTips=.T.
.MousePointer=15
Endwith
Endproc
Procedure combo1.Init
With This
For i=1 To 10
.AddItem("Item"+Trans(i))
Endfor
.ListIndex=1
.Style=2
Endwith
Endproc
Enddefine
*
*-- EndDefine: asup
*Author: Marcia Atkins
*-- Time Stamp: 01/04/05 06:00:13 PM
*-- Self maximizing form for sovereign applications
* if need this to work on wide screen monitors, you will have to tweak the code for the different aspect ratio:
Define Class stdResizer As Custom
Height = 23
Width = 16
Name = "stdresizer"
Procedure saveoriginaldimensions
*-- Called from the resizer's init...saves the original dimension of all for objects...must be modified so it can be called explicitly when delayed instantiation is used
*Procedure saveoriginaldimensions
Lparameters tocontrol
Local loPage, loControl, loColumn, lnCol
*** If the object does not have an AddProperty method,
*** we can't add the properties to save the original dimension.
*** So bail out
If Not Pemstatus( tocontrol, 'AddProperty', 5 )
Return
Endif
With tocontrol
*** Go ahead and add the properties to hold the object's original dimensions
If Pemstatus( tocontrol, 'Width', 5 )
If Not Pemstatus( tocontrol, 'nOriginalWidth', 5 )
.AddProperty( 'nOriginalWidth', .Width )
Endif
Endif
If Pemstatus( tocontrol, 'Height', 5 )
If Not Pemstatus( tocontrol, 'nOriginalHeight', 5 )
.AddProperty( 'nOriginalHeight', .Height )
Endif
Endif
If Pemstatus( tocontrol, 'Top', 5 )
If Not Pemstatus( tocontrol, 'nOriginalTop', 5 )
.AddProperty( 'nOriginalTop', .Top )
Endif
Endif
If Pemstatus( tocontrol, 'Left', 5 )
If Not Pemstatus( tocontrol, 'nOriginalLeft', 5 )
.AddProperty( 'nOriginalLeft', .Left )
Endif
Endif
If Pemstatus( tocontrol, 'Fontsize', 5 )
If Not Pemstatus( tocontrol, 'nOriginalFontSize', 5 )
.AddProperty( 'nOriginalFontSize', .FontSize )
Endif
Endif
*** Now see if we have to drill down. Also, take care of special
*** case like grids where we have to save RowHeight, HeaderHeight, etc
*** And combos where we need to save ColumnWidths
Do Case
Case Upper( .BaseClass ) = 'PAGEFRAME'
For Each loPage In .Pages
This.saveoriginaldimensions( loPage )
Endfor
Case Inlist( Upper( .BaseClass ), 'PAGE', 'CONTAINER' )
For Each loControl In .Controls
This.saveoriginaldimensions( loControl )
Endfor
Case Upper( .BaseClass ) = 'GRID'
If Not Pemstatus( tocontrol, 'nOriginalRowHeight', 5 )
.AddProperty( 'nOriginalRowHeight', .RowHeight )
Endif
If Not Pemstatus( tocontrol, 'nOriginalHeaderHeight', 5 )
.AddProperty( 'nOriginalHeaderHeight', .HeaderHeight )
Endif
If Not Pemstatus( tocontrol, 'nOriginalColumnWidths[ 1 ]', 5 )
.AddProperty( 'nOriginalColumnWidths[ 1 ]' )
Endif
****
*** Changed By.: Marcia G. Akins on 15 September 2006
*** Reason.....: Causes a crashing error if grid has no columns
****
If .ColumnCount > 0
Dimension .nOriginalColumnWidths[ .ColumnCount ]
For lnCol = 1 To .ColumnCount
.nOriginalColumnWidths[lnCol] = .Columns[ lnCol ].Width
Endfor
Endif
Case Inlist( Upper( .BaseClass ), 'COMBOBOX', 'LISTBOX' )
If Not Pemstatus( tocontrol, 'nOriginalColumnWidths', 5 )
.AddProperty( 'nOriginalColumnWidths', .ColumnWidths )
Endif
Case Inlist( Upper( .BaseClass ), 'COMMANDGROUP', 'OPTIONGROUP' )
Local lnButton
For lnButton = 1 To .ButtonCount
This.saveoriginaldimensions( .Buttons[ lnButton ] )
Endfor
Otherwise
*** There is no otherwise...I think we got all cases
Endcase
Endwith
*Endproc
Endproc
Procedure resizecontrols
*-- Called from the adjustControls method, it resizes and repositions each control it is passed and drills down when necessary
*Procedure resizecontrols
Lparameters tocontrol, tnWidthRatio, tnHeightRatio
Local Array lnColumnWidths[ 1 ]
Local loPage, loControl, loColumn, lnCol
With tocontrol
If Pemstatus( tocontrol, 'Width', 5 )
If Pemstatus( tocontrol, 'nOriginalWidth', 5 )
.Width = .nOriginalWidth * tnWidthRatio
Endif
Endif
If Pemstatus( tocontrol, 'Height', 5 )
If Pemstatus( tocontrol, 'nOriginalHeight', 5 )
.Height = .nOriginalHeight * tnHeightRatio
Endif
Endif
If Pemstatus( tocontrol, 'Top', 5 )
If Pemstatus( tocontrol, 'nOriginalTop', 5 )
.Top = .nOriginalTop * tnHeightRatio
Endif
Endif
If Pemstatus( tocontrol, 'Left', 5 )
If Pemstatus( tocontrol, 'nOriginalLeft', 5 )
.Left = .nOriginalLeft * tnWidthRatio
Endif
Endif
*** Now resize the font of the control
*** But only if it is not a grid or an edit box. For these controls,
*** we want to see more info, not a bigger font
If Not Inlist( Upper( .BaseClass ), 'GRID', 'EDITBOX', 'LISTBOX' )
If Pemstatus( tocontrol, 'Fontsize', 5 )
If Pemstatus( tocontrol, 'nOriginalFontSize', 5 )
.FontSize = Iif( Int( .nOriginalFontSize * tnHeightRatio ) < 1, 1, ;
INT( .nOriginalFontSize * tnHeightRatio ) )
Endif
Endif
Endif
Do Case
Case Upper( .BaseClass ) = 'PAGEFRAME'
For Each loPage In .Pages
This.resizecontrols( loPage, tnWidthRatio, tnHeightRatio )
Endfor
Case Inlist( Upper( .BaseClass ), 'PAGE', 'CONTAINER' )
For Each loControl In .Controls
This.resizecontrols( loControl, tnWidthRatio, tnHeightRatio )
Endfor
Case Inlist( Upper( .BaseClass ), 'COMBOBOX', 'LISTBOX' )
Local lnCol, lnStart, lnEnd, lnLen, lcColumnWidths
If .ColumnCount < 2
.ColumnWidths = Alltrim( Str( .Width ) )
Else
lcColumnWidths = ''
lnStart = 1
For lnCol = 1 To .ColumnCount - 1
lnEnd = At( ',', .nOriginalColumnWidths, lnCol )
lnLen = lnEnd - lnStart
lcColumnWidths = lcColumnWidths + ;
IIF( Empty( lcColumnWidths ), '', ',' ) + ;
ALLTRIM( Str( Val( Substr( .nOriginalColumnWidths, lnStart, lnLen ) ) * tnWidthRatio ) )
lnStart = lnEnd + 1
Endfor
lnLen = Len( .nOriginalColumnWidths ) - lnStart + 1
lcColumnWidths = lcColumnWidths + ',' + ;
ALLTRIM( Str( Val( Substr( .nOriginalColumnWidths, lnStart, lnLen ) ) * tnWidthRatio ) )
.ColumnWidths = lcColumnWidths
Endif
Case Inlist( Upper( .BaseClass ), 'COMMANDGROUP', 'OPTIONGROUP' )
Local lnButton
For lnButton = 1 To .ButtonCount
This.resizecontrols( .Buttons[ lnButton ], tnWidthRatio, tnHeightRatio )
Endfor
Otherwise
*** There is no otherwise...I think we got all cases
Endcase
Endwith
* Endproc
Endproc
Procedure AdjustControls
*-- Called from the form's Resize even, it loops through the form's controls collection and passes a reference to each object to the class's ResizeControls method so it can be resized and/or drilled down into
*Procedure adjustcontrols
Lparameter tocontrol
Local llLockScreen, loControl, loParent, lnWidthRatio, lnHeightRatio
If Vartype( tocontrol ) # 'O' And Not Isnull( tocontrol )
loParent = This.Parent
Else
loParent = tocontrol
Endif
*** Bail out if the any of the required properties are not found in the
*** parent container
If Not Pemstatus( Thisform, 'nOriginalWidth', 5 )
Return
Endif
If Not Pemstatus( Thisform, 'nOriginalHeight', 5 )
Return
Endif
With Thisform
lnWidthRatio = .Width / .nOriginalWidth
lnHeightRatio = .Height / .nOriginalHeight
*** Save current status of LockScreen
llLockScreen = .LockScreen
.LockScreen = .T.
For Each loControl In loParent.Controls
This.resizecontrols( loControl, lnWidthRatio, lnHeightRatio )
Endfor
.LockScreen = llLockScreen
Endwith
* Endproc
Endproc
Procedure Init
* Procedure Init
Local loContainer, loControl
loContainer = This.Parent
With loContainer
*** If the parent continer doesn't have the nOriginalHeight and nOriginalWidth properties
*** then add them and save the form dimensions
If Not Pemstatus( loContainer, 'nOriginalHeight', 5 )
.AddProperty( 'nOriginalHeight', .Height )
Endif
If Not Pemstatus( loContainer, 'nOriginalWidth', 5 )
.AddProperty( 'nOriginalWidth', .Width )
Endif
*** Set a minimun Width and Height to avoid errors later if not
*** already set
If .MinWidth = -1
.MinWidth = .Width / 2
Endif
If .MinHeight = -1
.MinHeight = .Height / 2
Endif
*** Now save the relevant visual properties (height, width, columnwidths, etc)
*** of all the controls on the parent container
For Each loControl In .Controls
This.saveoriginaldimensions( loControl )
Endfor
Endwith
* Endproc
Endproc
Enddefine
*-- EndDefine: stdresizer
Define Class ycont As Container
Top = 264
Left = 9
Width = 432
Height = 157
Name = "Container1"
Add Object edit1 As EditBox With ;
Height = 133, ;
Left = 12, ;
Top = 12, ;
Width = 205, ;
Name = "Edit1"
Add Object command1 As CommandButton With ;
Top = 4, ;
Left = 244, ;
Height = 37, ;
Width = 145, ;
Caption = "Command1", ;
Name = "Command1"
Add Object image1 As Image With ;
Picture = "..\..\_____100photos\tiout g+\sam_3059_resized.jpg", ;
Stretch = 2, ;
Height = 97, ;
Left = 220, ;
Top = 48, ;
Width = 205, ;
Name = "Image1"
Procedure edit1.Init
TEXT to this.value noshow
Lorem ipsum dolor sit amet, consectetur adipiscing elit. Proin vel risus eget lorem feugiat
fermentum nec a turpis. Phasellus purus sem, mollis ac posuere eget, ornare vel orci. Sed ac rutrum
nulla. Aenean ultrices eget lectus eu efficitur. In hac habitasse platea dictumst. Nulla in iaculis nisi.
Nullam et pulvinar tellus. Donec arcu dui, efficitur a odio non, porta congue dolor. Aenean viverra
auctor sagittis. Integer lobortis dignissim auctor. Proin et volutpat massa.
ENDTEXT
Endproc
Procedure Init
This.SetAll("mousepointer",15,"commandbutton")
Endproc
Enddefine
*
*-- EndDefine: ycont
function yloadImg
lparameters lcURl
Local loRequest
m.loRequest = Createobject('MsXml2.XmlHttp')
m.loRequest.Open("GET",lcUrl,.F.)
m.loRequest.Send()
return(m.loRequest.ResponseBody )
m.loRequest=Null
endfunc
Click on code to select [then copy] -click outside to deselect
I struggled in previous posts to make the form titlebar traversable by adding object as commndbuttons, colors,..
and other stuffs.this was difficult because there is no vfp way actually to work inside the system titlebar.
i subclassed successfully this titlebar by a container...the only way to work with transparency in a container
is to erase one specific color with setLayeredWindow API but applied to all the form.
this is another singular way to do that but with 2 forms.
form is a vfp object having a real windows handle HWND and then can be manipulated with transparency.
A top level form (alwaysonTop) desserves this goal.
A normal top level form (alwaysOnTop) works as a normal form.
the 2 forms are synchronized with code (in particular, form moved event) to work as well as one form.
the first form (titlebar) have transparency variable manually.a value 200 to 210 is available for view.
the transparency is variable form 160-255(opaque).
i added 3 methods to make gradients in a bitmap covering the titlebar.
the colors can be choosed randomly.can be also form .backcolor property.
the titlebar height is variable form 33-66 pixels.
can insert any object...i designed some menus for demo.
notes:
-click to titlebar form to give the focusfor showing tooltips.
*re click rounded shapes buttons to refresh the titlebar gradients randomly
*once setting background color , image becomes invisible-set a picture (second shape) before running left menu (make image visible).
-the code downloads automatically 15 images.run this once and change ydownl=.f.
Click on code to select [then copy] -click outside to deselect
![]()
*2* a singular form titlebar---version2 *created on 23 of april 2017 -- updated on 25 of april 2017 (added a lightbox) *remember that transparency on a vfp form can be applied only in 2 cases * - on top level form (showWindow=2) * - a form with (showWindow=0,1 and mandatory desktop=.t.) *put the gdiplusX library: system.app in source folder to work with lightbox. Publ m.yrep m.yrep=Addbs(Justpath(Sys(16,1))) Set Defa To (yrep) Local ydownl m.ydownl=.t. &&done 1 once and change ydownl=.f. here to dont re download each time If m.ydownl=.T. *download some images from my blog (used by this code)-verify that all 15 imags are downloaded as well. *can comment these lines after downloading images to run the code *******begin downloads************ Declare Integer URLDownloadToFile In urlmon.Dll Integer pCaller, String szURL, String szFileName, Integer dwReserved, Integer lpfnCB Declare Integer DeleteUrlCacheEntry In wininet String lpszUrlName Local lcUrl,lcDownloadLoc For i=1 To 15 Do Case Case i=1 lcUrl="http://img.over-blog-kiwi.com/300x225-ct/1/43/54/07/20170423/ob_dc2c0d_adobe-pdf-reader.png" lcDownloadLoc="adobe_pdf_reader.png" Case i=2 lcUrl="http://img.over-blog-kiwi.com/300x225-ct/1/43/54/07/20170423/ob_5320f1_bambou.jpg" lcDownloadLoc="bambou.jpg" Case i=3 lcUrl="http://img.over-blog-kiwi.com/300x225-ct/1/43/54/07/20170423/ob_f4c5ca_bluetab.jpg" lcDownloadLoc="bluetab.jpg" Case i=4 lcUrl="http://img.over-blog-kiwi.com/300x225-ct/1/43/54/07/20170423/ob_c74bf1_button-10.png" lcDownloadLoc="button_10.png" Case i=5 lcUrl="http://img.over-blog-kiwi.com/200x150-ct/1/43/54/07/20170423/ob_a927cd_fonds.jpg" lcDownloadLoc="fonds.jpg" Case i=6 lcUrl="http://img.over-blog-kiwi.com/200x150-ct/1/43/54/07/20170423/ob_a8e884_fonds-wrapper.jpg" lcDownloadLoc="fonds_wrapper.jpg" Case i=7 lcUrl="http://img.over-blog-kiwi.com/200x150-ct/1/43/54/07/20170423/ob_c8fe9e_texture.jpg" lcDownloadLoc="texture.jpg" Case i=8 lcUrl="http://img.over-blog-kiwi.com/200x150-ct/1/43/54/07/20170423/ob_4210e9_texture1.png" lcDownloadLoc="texture1.png" Case i=9 lcUrl="http://img.over-blog-kiwi.com/200x150-ct/1/43/54/07/20170423/ob_58df6d_texture2.jpg" lcDownloadLoc="texture2.jpg" Case i=10 lcUrl="http://img.over-blog-kiwi.com/200x150-ct/1/43/54/07/20170423/ob_caa906_texture3.JPG" lcDownloadLoc="texture3.jpg" Case i=11 lcUrl="http://img.over-blog-kiwi.com/1/43/54/07/20170425/ob_d8492c_cap2.JPG" lcDownloadLoc="cap2.jpg" Case i=12 lcUrl="http://img.over-blog-kiwi.com/1/43/54/07/20170425/ob_7d1959_cap3.JPG" lcDownloadLoc="cap3.jpg" Case i=13 lcUrl="http://img.over-blog-kiwi.com/1/43/54/07/20170425/ob_f5c9d6_cap8.JPG" lcDownloadLoc="cap8.jpg" Case i=14 lcUrl="http://img.over-blog-kiwi.com/1/43/54/07/20170425/ob_60f4b1_cap9.JPG" lcDownloadLoc="cap9.jpg" Case i=15 lcUrl="http://img.over-blog-kiwi.com/1/43/54/07/20170425/ob_3d8af8_cap7.JPG" lcDownloadLoc="cap7.jpg" Endcase lnResult = DeleteUrlCacheEntry(lcUrl) lnResult = URLDownloadToFile(0, lcUrl, lcDownloadLoc , 0,0) If lnResult = 0 Wait Window "Download "+lcDownloadLoc +" Complete" Nowait *Else *!* Messagebox("Download fails") Endi Inke(1) Endfor **********end downloads**************** Endi _Screen.WindowState=1 Publi yform yform=Newobject("yaerot") yform.Show Read Events Retu * Define Class yaerot As Form BorderStyle = 0 Top = 55 Left = 35 Height = 473 Width = 863 ShowWindow = 2 Caption = "" AlwaysOnTop = .T. BackColor = Rgb(212,210,208) xheight_ = 0 Name = "yaerot" Add Object command1 As CommandButton With ; Top = 99, ; Left = 36, ; Height = 85, ; Width = 181, ; FontBold = .T., ; FontSize = 18, ; Picture = Home(1)+"graphics\icons\misc\face05.ico", ; Caption = "Command1", ; PicturePosition = 2, ; BackColor = Rgb(128,255,0), ; Name = "Command1" Add Object text1 As TextBox With ; FontBold = .T., ; Value = "Hello World !", ; Height = 36, ; Left = 588, ; Top = 432, ; Width = 133, ; Name = "Text1" Add Object image1 As Image With ; Picture = "fonds.jpg", ; Stretch = 2, ; Height = 96, ; Left = 24, ; Top = 1, ; Width = 120, ; Name = "Image1" Add Object grid1 As Grid With ; Height = 253, ; Left = 24, ; Top = 197, ; Width = 445, ; Name = "Grid1" Add Object olecontrol1 As OleControl With ; oleclass="shell.explorer.2", ; Top = 84, ; Left = 480, ; Height = 337, ; Width = 349, ; Name = "Olecontrol1" Add Object timer1 As Timer With ; Top = 72, ; Left = 804, ; Height = 23, ; Width = 23, ; Enabled = .F., ; Interval = 10000, ; Name = "Timer1" Add Object label1 As Label With ; AutoSize = .T., ; FontBold = .T., ; FontSize = 28, ; Anchor = 768, ; BackStyle = 0, ; Caption = "?", ; Height = 47, ; Left = 820, ; MousePointer = 15, ; Top = 9, ; Width = 25, ; ForeColor = Rgb(0,255,0), ; Name = "Label1" Add Object olecontrol2 As OleControl With ; Oleclass="MSComCtl2.MonthView.2", ; Top = 12, ; Left = 252, ; Height = 169, ; Width = 205, ; Name = "Olecontrol2" Add Object label2 As Label With ; AutoSize = .T., ; FontBold = .T., ; FontName = "Segoe Script", ; FontSize = 32, ; BackStyle = 0, ; Caption = "Hello World", ; Height = 74, ; Left = 532, ; Top = 11, ; Width = 280, ; ForeColor = Rgb(0,255,0), ; Name = "Label2" Add Object label3 As Label With ; AutoSize = .T., ; FontBold = .T., ; FontName = "Segoe Script", ; FontSize = 32, ; BackStyle = 0, ; Caption = "Hello World", ; Height = 74, ; Left = 526, ; Top = 11, ; Width = 280, ; ForeColor = Rgb(255,128,0), ; Name = "Label3" Procedure ybuild Lparameters ximage Local m.myvar TEXT to m.myvar textmerge noshow <!DOCTYPE html> <html> <head> <meta charset="utf-8"> <meta http-equiv="X-UA-Compatible" content="IE=edge,chrome=1"> <meta name="viewport" content="width=device-width"> <title>Three.js basic cube example</title> <style> html,body { margin: 0; } body { overflow: hidden; } </style> </head> <body oncontextmenu="return false;" > <script src="https://mdn.github.io/learning-area/javascript/apis/drawing-graphics/threejs-cube/three.min.js"></script> <script > var scene = new THREE.Scene(); var camera = new THREE.PerspectiveCamera(75, window.innerWidth / window.innerHeight, 0.1, 1000); camera.position.z = 5; var renderer = new THREE.WebGLRenderer(); renderer.setSize(window.innerWidth, window.innerHeight); document.body.appendChild(renderer.domElement); var cube; var loader = new THREE.TextureLoader(); loader.load( '<<allt(ximage)>>', function (texture) { texture.wrapS = THREE.RepeatWrapping; texture.wrapT = THREE.RepeatWrapping; texture.repeat.set(2, 2); var geometry = new THREE.BoxGeometry(2.4,2.4,2.4); var material = new THREE.MeshLambertMaterial( { map: texture, shading: THREE.FlatShading } ); cube = new THREE.Mesh(geometry, material); scene.add(cube); draw(); }); var light = new THREE.AmbientLight('rgb(255,255,255)'); // soft white light scene.add(light); var spotLight = new THREE.SpotLight('rgb(255,255,255)'); spotLight.position.set( 100, 1000, 1000 ); spotLight.castShadow = true; scene.add(spotLight); function draw() { cube.rotation.x += 0.01; cube.rotation.y += 0.01; renderer.render(scene, camera); requestAnimationFrame(draw); } </script> </body> </html> ENDTEXT Set Safe Off Local m.lcdest m.lcdest=m.yrep+"ytemp.html" Strtofile(m.myvar,m.lcdest) Thisform.olecontrol1.Navigate(m.lcdest) Endproc Procedure Moved Try If Thisform.WindowState=0 yform1.WindowState=0 This.Resize Endi If Thisform.WindowState=1 yform1.WindowState=1 Endi Catch Endtry Endproc Procedure MouseDown Lparameters nButton, nShift, nXCoord, nYCoord lnHandle = Thisform.HWnd param1 = 274 param2 = 0xF012 bb=ReleaseCapture() bb=SendMessage(lnHandle, param1, param2,0) Thisform.Resize Endproc Procedure Resize With Thisform Try .Left=yform1.Left .Top=yform1.Top+yform1.Height .Width=yform1.Width Catch Endtry Endwith Endproc Procedure Init This.TitleBar=0 Create Cursor zcurs (ximage c(100)) Insert Into zcurs Values ("texture.jpg") Insert Into zcurs Values ("texture1.png") Insert Into zcurs Values ("texture2.jpg") Insert Into zcurs Values ("texture3.jpg") Sele zcurs Locate Thisform.ybuild(Allt(ximage)) Thisform.timer1.Enabled=.T. Sele * From Home(1)+"samples\data\customer" Into Cursor ycurs With This.grid1 .RecordSource="" .RecordSource="ycurs" .RecordSourceType=1 .DeleteMark=.F. .GridLines=0 .FontBold=.T. .SetAll("DynamicBackColor", "IIF(MOD(RECNO( ), 2)=0, RGB(145,55,105) , RGB(100,255,40))", "Column") Sele ycurs Locate .Refresh Endwith Publi yform1 yform1=Newobject("yaerot0") yform1.Show Thisform.Resize() Endproc Procedure olecontrol1.Init This.silent=.T. Endproc Procedure timer1.Timer Sele zcurs Try Skip Catch Locate Endtry If Empty(ximage) Locate Endi Thisform.ybuild(ximage) Endproc Procedure label1.Click Local m.myvar TEXT to m.myvar pretext 7 noshow I struggled in previous posts to make the form titlebar traversable by adding object as commndbuttons, colors,.. and other stuffs.this was difficult because there is no vfp way actually to work inside the system titlebar. i subclassed successfully this titlebar by a container...the only way to work with transparency in a container is to erase one specific color with setLayeredWindow API but applied to all the form. the 10 images demo download can be used 1 once(and change ydownl=.f. in code) this is another singular way to do that but with 2 forms. form is a vfp object having a real windows handle HWND and then can be manipulated with transparency. A top level form (alwaysonTop) desserves this goal. A normal top level form (alwaysOnTop) works as a normal form. the 2 forms are synchronized with code (in particular, form moved event) to work as well as one form. the first form (titlebar) have transparency variable manually.a value 200 to 210 is available for view. the transparency is variable form 160-255(opaque). i added 3 methods to make gradients in a bitmap covering the titlebar. the colors can be choosed randomly.can be also form .backcolor property. the titlebar height is variable form 33-66 pixels. can insert any object...i designed some menus for demo. the titlebar shape6 offers a similar lightbox with a random color on the form (yform).can choose a fixed balcky color as rgb(28,28,28).click on form empty area to restore.Note the image created(destroyed) cannot be on top of activeX(always topmost) ENDTEXT *Messagebox(m.myvar,0+32+4096,"Summary help") Local oshell oshell = Createobject('WScript.Shell') oshell.Popup(m.myvar,0, 'Summary help', 0+32+4096) &&4,16,48,64... oshell=Null Endproc Procedure olecontrol2.Init With This .BackColor=4227327 .ForeColor=16711680 .appearance=0 .BorderStyle=0 .monthBackcolor=Rgb(225,238,200) .titleBackcolor=4259584 Endwith Endproc Procedure Destroy Try &&release titlebar if releasing yform from taskbar yform1.Release Catch Endtry Clea Events Endproc Enddefine * *-- EndDefine: yaerot Define Class yaerot0 As Form BorderStyle = 1 &&0,1 Top = 189 Left = 79 Height = 66 Width = 863 ShowWindow = 2 ShowInTaskbar = .F. ShowTips = .T. Picture = "" Caption = "Form1" AlwaysOnTop = .T. BackColor = Rgb(128,0,64) xleft = .F. xtop = .F. xwidth = .F. xheight = .F. Name = "yaerot0" Add Object image1 As Image With ; Anchor = 15, ; Picture = "bluetab.jpg", ; Stretch = 2, ; BorderStyle = 1, ; Height = 600, ; Left = 0, ; Top = 0, ; Width = 600, ; Name = "Image1" Add Object command1 As CommandButton With ; Top = 7, ; Left = 837, ; Height = 20, ; Width = 20, ; FontBold = .T., ; FontSize = 12, ; Anchor = 768, ; Caption = "X", ; MousePointer = 15, ; SpecialEffect = 2, ; ForeColor = Rgb(255,0,0), ; BackColor = Rgb(128,255,0), ; Name = "Command1" Add Object spinner1 As Spinner With ; Anchor = 768, ; Height = 25, ; KeyboardHighValue = 255, ; KeyboardLowValue = 150, ; Left = 715, ; SpinnerHighValue = 255.00, ; SpinnerLowValue = 160.00, ; ToolTipText = "Transparency 150-255", ; Top = 5, ; Width = 61, ; Value = 205, ; Name = "Spinner1" Add Object shape1 As Shape With ; Top = 11, ; Left = 618, ; Height = 13, ; Width = 13, ; Anchor = 768, ; Curvature = 99, ; MousePointer = 15, ; ToolTipText = "Background", ; BackColor = Rgb(0,255,0), ; Name = "Shape1" Add Object shape2 As Shape With ; Top = 11, ; Left = 600, ; Height = 13, ; Width = 13, ; Anchor = 768, ; Curvature = 99, ; MousePointer = 15, ; ToolTipText = "Backcolor", ; BackColor = Rgb(255,0,0), ; Name = "Shape2" Add Object command2 As CommandButton With ; Top = 7, ; Left = 791, ; Height = 20, ; Width = 20, ; FontBold = .T., ; FontSize = 12, ; Anchor = 768, ; Caption = "-", ; MousePointer = 15, ; SpecialEffect = 2, ; ForeColor = Rgb(255,0,0), ; BackColor = Rgb(128,255,0), ; Name = "Command2" Add Object image2 As Image With ; Anchor = 768, ; Picture = "button_10.png", ; Stretch = 2, ; Height = 25, ; Left = 101, ; MousePointer = 15, ; Top = 12, ; Width = 109, ; ToolTipText = "Contextuel menu", ; Name = "Image2" Add Object command3 As CommandButton With ; Top = 7, ; Left = 814, ; Height = 20, ; Width = 20, ; FontBold = .T., ; FontName = "Webdings", ; FontSize = 9, ; Anchor = 768, ; Caption = "1", ; MousePointer = 15, ; SpecialEffect = 2, ; ForeColor = Rgb(255,0,0), ; BackColor = Rgb(128,255,0), ; Name = "Command3" Add Object image3 As Image With ; Anchor = 768, ; Picture = "adobe_pdf_reader.png", ; Stretch = 2, ; Height = 33, ; Left =5, ; MousePointer = 15, ; Top = 10 , ; Width = 33, ; ToolTipText = "Menu", ; Name = "Image3" Add Object yshape As Shape With ; Top = 11, ; Left = 63, ; Height = 13, ; Width = 18, ; Anchor = 768, ; Curvature = 10, ; MousePointer = 15, ; ToolTipText = "Pictures backg", ; BackColor =0, ; BorderColor = Rgb(255,255,255), ; BorderWidth=1,; Name = "yShape" Add Object shape3 As Shape With ; Top = 11, ; Left = 638, ; Height = 13, ; Width = 13, ; Anchor = 768, ; Curvature = 99, ; MousePointer = 15, ; ToolTipText = "Grad random", ; BackColor = Rgb(255,255,0), ; BorderColor = Rgb(255,255,128), ; Name = "Shape3" Add Object shape4 As Shape With ; Top = 11, ; Left = 663, ; Height = 13, ; Width = 13, ; Anchor = 768, ; Curvature = 99, ; MousePointer = 15, ; ToolTipText = "Grad 2 colors", ; BackColor = Rgb(0,255,255), ; Name = "Shape4" Add Object spinner2 As Spinner With ; Anchor = 768, ; Height = 25, ; KeyboardHighValue = 66, ; KeyboardLowValue = 33, ; Left = 527, ; SpinnerHighValue = 66.00, ; SpinnerLowValue = 33.00, ; ToolTipText = "Resize titlebar", ; Top = 5, ; Width = 61, ; Value = 66, ; Name = "Spinner2" Add Object shape5 As Shape With ; Top = 11, ; Left = 684, ; Height = 13, ; Width = 13, ; Anchor = 768, ; Curvature = 99, ; MousePointer = 15, ; ToolTipText = "Grad random 2 colors", ; BackColor = Rgb(255,128,64), ; Name = "Shape5" Add Object shape6 As Shape With ; Top = 11, ; Left = 684+15, ; Height = 13, ; Width = 13, ; Anchor = 768, ; Curvature = 99, ; MousePointer = 15, ; ToolTipText = "Lightbox/1 rand color", ; BackColor = Rgb(128,0,255), ; Name = "Shape6" Procedure ytranspa Lparameters opa If !Between(opa,0,255) opa=255 Endi #Define GWL_EXSTYLE -20 #Define WS_EX_LAYERED 0x80000 #Define LWA_COLORKEY 1 #Define LWA_ALPHA 2 Local nExStyle, nRgb, nAlpha, nFlags nExStyle = GetWindowLong(Thisform.HWnd, GWL_EXSTYLE) nExStyle = Bitor(nExStyle, WS_EX_LAYERED) = SetWindowLong(Thisform.HWnd, GWL_EXSTYLE, nExStyle) = SetLayeredWindowAttributes(Thisform.HWnd, Thisform.BackColor, opa,LWA_ALPHA) Endproc Procedure rgb2html Lparameters tnColor Local loColor loColor = Createobject("Empty") AddProperty(loColor, "nR", Bitand(tnColor, 0xFF)) AddProperty(loColor, "nG", Bitand(Bitrshift(tnColor, 8), 0xFF)) AddProperty(loColor, "nB", Bitand(Bitrshift(tnColor, 16), 0xFF)) AddProperty(loColor, "cHTMLcolor", Strtran("#" + ; TRANSFORM(loColor.nR, "@0") + ; TRANSFORM(loColor.nG, "@0") + ; TRANSFORM(loColor.nB, "@0"), "0x000000", "" )) Return loColor.cHTMLcolor Endproc Procedure DblClick Thisform.command3.Click() Endproc Procedure Moved Try With yform .Left=This.Left .Top=This.Top+This.Height .Width=This.Width .WindowState=Thisform.WindowState Endwith Catch Endtry Endproc Procedure MouseDown Lparameters nButton, nShift, nXCoord, nYCoord This.MousePointer=15 lnHandle = Thisform.HWnd param1 = 274 param2 = 0xF012 bb=ReleaseCapture() bb=SendMessage(lnHandle, param1, param2,0) This.MousePointer=0 Endproc Procedure KeyPress Lparameters nKeyCode, nShiftAltCtrl If nKeyCode=27 Try yform.Release Catch Endtry Thisform.Release Endi Endproc Procedure Init Thisform.TitleBar=0 Set Safe Off Thisform.ytranspa(210) Endproc Procedure Destroy Clea Events Endproc Procedure image1.DblClick Thisform.command3.Click Endproc Procedure image1.Init With This .Left=0 .Top=0 .Width=.Parent.Width+5 .Height=.Parent.Height+5 .ZOrder(1) Endwith Endproc Procedure image1.MouseDown Lparameters nButton, nShift, nXCoord, nYCoord This.MousePointer=15 lnHandle = Thisform.HWnd param1 = 274 param2 = 0xF012 bb=ReleaseCapture() bb=SendMessage(lnHandle, param1, param2,0) This.MousePointer=0 Endproc Procedure command1.MouseEnter Lparameters nButton, nShift, nXCoord, nYCoord This.BackColor=255 Endproc Procedure command1.MouseLeave Lparameters nButton, nShift, nXCoord, nYCoord This.BackColor=Rgb(0,255,0) Endproc Procedure command1.Click Try yform.Release Catch Endtry Thisform.Release Endproc Procedure spinner1.InteractiveChange Thisform.ytranspa(This.Value) Endproc Procedure yshape.RightClick This.Click Endproc Procedure yshape.Click Define Popup raccourci SHORTCUT Color N/w*,G+/N*,,,,N/R Relative From Mrow(),Mcol() Define Bar 1 Of raccourci Prompt "1" ; PICTURE "cap2.jpg" Define Bar 2 Of raccourci Prompt "2" ; PICTURE "cap3.jpg" Define Bar 3 Of raccourci Prompt "3" ; PICTURE "cap8.jpg" Define Bar 4 Of raccourci Prompt "4" ; PICTURE "cap9.jpg" Define Bar 5 Of raccourci Prompt "5" ; PICTURE "cap7.jpg" On Selection Bar 1 Of raccourci _Screen.ActiveForm.image1.Picture="cap2.jpg" On Selection Bar 2 Of raccourci _Screen.ActiveForm.image1.Picture="cap3.jpg" On Selection Bar 3 Of raccourci _Screen.ActiveForm.image1.Picture="cap8.jpg" On Selection Bar 4 Of raccourci _Screen.ActiveForm.image1.Picture="cap9.jpg" On Selection Bar 5 Of raccourci _Screen.ActiveForm.image1.Picture="cap7.jpg" Activate Popup raccourci Endproc Procedure shape1.Click Local m.xpict m.xpict=Getpict() If ! Empty(m.xpict) Thisform.image1.Picture=m.xpict Thisform.image1.Visible=.T. Endi Endproc Procedure shape2.Click Local m.xcolor m.xcolor=Getcolor() If ! Empty(m.xcolor) Thisform.BackColor=m.xcolor Thisform.image1.Visible=.F. Endi Endproc Procedure command2.MouseLeave Lparameters nButton, nShift, nXCoord, nYCoord This.BackColor=Rgb(0,255,0) Endproc Procedure command2.MouseEnter Lparameters nButton, nShift, nXCoord, nYCoord This.BackColor=255 Endproc Procedure command2.Click Try yform.WindowState=1 Catch Endtry Thisform.WindowState=1 Endproc Procedure image2.RightClick This.Click() Endproc Procedure image2.Click Define Popup raccourci SHORTCUT Relative From Mrow(),Mcol() Define Bar _Med_slcta Of raccourci Prompt "Sélectionner tout" ; KEY CTRL+A, "Ctrl+A" ; PICTRES _Med_slcta ; MESSAGE "Sélectionne tout le texte ou tous les éléments de la fenêtre active" Define Bar _Med_paste Of raccourci Prompt "Coller" ; KEY CTRL+V, "Ctrl+V" ; PICTRES _Med_paste ; MESSAGE "Place le contenu du Presse-papiers au point d'insertion" Define Bar _Med_copy Of raccourci Prompt "Copier" ; KEY CTRL+c, "Ctrl+C" ; PICTRES _Med_copy ; MESSAGE "Copie la sélection et la place dans le Presse-papiers" Define Bar _Med_cut Of raccourci Prompt "Couper" ; KEY CTRL+X, "Ctrl+X" ; PICTRES _Med_cut ; MESSAGE "Enlève la sélection et la place dans le Presse-papiers" Define Bar _Med_redo Of raccourci Prompt "Rétablir" ; KEY CTRL+R, "Ctrl+R" ; PICTRES _Med_redo Define Bar _Med_undo Of raccourci Prompt "Annuler" ; KEY CTRL+Z, "Ctrl+Z" ; PICTRES _Med_undo ; MESSAGE "Annule la dernière modification" Activate Popup raccourci Endproc Procedure command3.MouseEnter Lparameters nButton, nShift, nXCoord, nYCoord This.BackColor=255 Endproc Procedure command3.MouseLeave Lparameters nButton, nShift, nXCoord, nYCoord This.BackColor=Rgb(0,255,0) Endproc Procedure command3.Click Do Case Case This.Caption=="1" Try With Thisform .xleft=.Left .xtop=.Top .xwidth=.Width .xheight=.Height .Left=0 .Top=0 .Width=Sysmetric(1) .Refresh Endwith With yform .xheight_=.Height .Resize() .Height=Sysmetric(2)-Thisform.Height Endwith This.Caption="2" Catch Endtry Case This.Caption=="2" This.Caption="1" With Thisform .Left=.xleft .Top=.xtop .Width=.xwidth Endwith Try With yform .Resize() .Height=.xheight_ Endwith Catch Endtry Endcase Endproc Procedure image3.Click Define Popup raccourci SHORTCUT Relative From Mrow(),Mcol() Define Bar 1 Of raccourci Prompt "Hide menu" ; FONT "Courier New", 8 Style "BI" Color G/w*, B/w*,,,,w+/GR ; PICTURE (Home(1)+"GRAPHICS\ICONS\INDUSTRY\SINEWAVE.ICO") Define Bar 2 Of raccourci Prompt "Run vfp9" ; FONT "Courier New", 8 Style "BI" Color G/w*, B/w*,,,,w+/GR Define Bar 3 Of raccourci Prompt "Run explorer" ; FONT "Courier New", 8 Style "BI" Color G/w*, B/w*,,,,w+/GR ; PICTURE (Home(1)+"GRAPHICS\ICONS\misc\camera.ico") Define Bar 4 Of raccourci Prompt "Run Mspaint" ; FONT "Courier New", 8 Style "BI" Color G/w*, B/w*,,,,w+/GR ; PICTURE (Home(1)+"GRAPHICS\ICONS\misc\misc15.ico") Define Bar 5 Of raccourci Prompt "Run Calculator" ; FONT "Courier New", 8 Style "BI" Color G/w*, B/w*,,,,w+/GR ; PICTURE (Home(1)+"GRAPHICS\ICONS\misc\volume01.ico") Define Bar 6 Of raccourci Prompt "yClock-calendar" ; FONT "Courier New", 8 Style "BI" Color G/w*, B/w*,,,,w+/GR; PICTURE (Home(1)+"GRAPHICS\ICONS\misc\misc01.ico") Define Bar 7 Of raccourci Prompt "Run Notepad" ; FONT "Courier New", 8 Style "BI" Color G/w*, B/w*,,,,w+/GR; PICTURE (Home(1)+"GRAPHICS\ICONS\misc\misc02.ico") Define Bar 8 Of raccourci Prompt "Run Notepad++" ; FONT "Courier New", 8 Style "BI" Color G/w*, B/w*,,,,w+/GR; PICTURE (Home(1)+"GRAPHICS\ICONS\misc\misc03.ico") Define Bar 9 Of raccourci Prompt "Horloge Windows" ; FONT "Courier New", 8 Style "BI" Color G/w*, B/w*,,,,w+/GR; PICTURE (Home(1)+"GRAPHICS\ICONS\misc\misc04.ico") Define Bar 10 Of raccourci Prompt "Run Wordpad" ; FONT "Courier New", 8 Style "BI" Color G/w*, B/w*,,,,w+/GR; PICTURE (Home(1)+"GRAPHICS\ICONS\misc\misc05.ico") Define Bar 11 Of raccourci Prompt "Run yCap" ; FONT "Courier New", 8 Style "BI" Color G/w*, B/w*,,,,w+/GR; PICTURE (Home(1)+"GRAPHICS\ICONS\misc\misc06.ico") Define Bar 12 Of raccourci Prompt "Resize images wia" ; FONT "Courier New", 8 Style "BI" Color G/w*, B/w*,,,,w+/GR; PICTURE (Home(1)+"GRAPHICS\ICONS\misc\misc07.ico") Define Bar 13 Of raccourci Prompt "yPDFReader" ; FONT "Courier New", 8 Style "BI" Color G/w*, B/w*,,,,w+/GR; PICTURE (Home(1)+"GRAPHICS\ICONS\misc\misc08.ico") Define Bar 14 Of raccourci Prompt "Google Earth" ; FONT "Courier New", 8 Style "BI" Color G/w*, B/w*,,,,w+/GR; PICTURE (Home(1)+"GRAPHICS\ICONS\misc\misc09.ico") Define Bar 15 Of raccourci Prompt "Windows recorder" ; FONT "Courier New", 8 Style "BI" Color G/w*, B/w*,,,,w+/GR; PICTURE (Home(1)+"GRAPHICS\ICONS\misc\misc10.ico") Define Bar 16 Of raccourci Prompt "OpenOffice" ; FONT "Courier New", 8 Style "BI" Color G/w*, B/w*,,,,w+/GR; PICTURE (Home(1)+"GRAPHICS\ICONS\misc\misc11.ico") Define Bar 17 Of raccourci Prompt "Paintshop PSp" ; FONT "Courier New", 8 Style "BI" Color G/w*, B/w*,,,,w+/GR; PICTURE (Home(1)+"GRAPHICS\ICONS\misc\misc12.ico") Define Bar 18 Of raccourci Prompt "Anim" ; FONT "Courier New", 8 Style "BI" Color G/w*, B/w*,,,,w+/GR; PICTURE (Home(1)+"GRAPHICS\ICONS\misc\misc13.ico") Define Bar 19 Of raccourci Prompt "Snipping Tool Capture" ; FONT "Courier New", 8 Style "BI" Color G/w*, B/w*,,,,w+/GR; PICTURE (Home(1)+"GRAPHICS\ICONS\misc\misc14.ico") Define Bar 20 Of raccourci Prompt "WMPlayer" ; FONT "Courier New", 8 Style "BI" Color G/w*, B/w*,,,,w+/GR; PICTURE (Home(1)+"GRAPHICS\ICONS\misc\misc34.ico") Define Bar 21 Of raccourci Prompt "yMeteo" ; FONT "Courier New",8 Style "BI" Color G/w*, B/w*,,,,w+/GR; PICTURE (Home(1)+"GRAPHICS\ICONS\misc\misc35.ico") Define Bar 22 Of raccourci Prompt "DOS CMD.exe" ; FONT "Courier New",8 Style "BI" Color G/w*, B/w*,,,,w+/GR; PICTURE (Home(1)+"GRAPHICS\ICONS\misc\misc36.ico") On Selection Bar 1 Of raccourci On Selection Bar 2 Of raccourci On Selection Bar 3 Of raccourci On Selection Bar 4 Of raccourci On Selection Bar 5 Of raccourci On Selection Bar 6 Of raccourci On Selection Bar 7 Of raccourci On Selection Bar 8 Of raccourci On Selection Bar 9 Of raccourci On Selection Bar 10 Of raccourci On Selection Bar 11 Of raccourci On Selection Bar 12 Of raccourci On Selection Bar 13 Of raccourci On Selection Bar 14 Of raccourci On Selection Bar 15 Of raccourci On Selection Bar 16 Of raccourci On Selection Bar 17 Of raccourci On Selection Bar 18 Of raccourci On Selection Bar 19 Of raccourci On Selection Bar 20 Of raccourci On Selection Bar 21 Of raccourci On Selection Bar 22 Of raccourci Activate Popup raccourci Thisform.command2.Click() &&reduce to execute enu option because topmost Messagebox("can code menu execution....",0+32+4096,'',1000) Thisform.WindowState=0 Try yform.WindowState=0 Catch Endtry Endproc Procedure shape3.Click *create horizontal bmp image with linear gradient 2 color randomly Local nWidth,lnHeight As Integer Set Classlib To Locfile (Home(1)+"ffc\_gdiplus.vcx") Local OBitmap, oGraphics, Open, nY,nX, cFileName *hoprizontal lnWidth= 130 lnHeight= 30 m.cFileName ="ygradH.bmp" m.OBitmap = Createobject ("gpBitmap") m.OBitmap. Create (lnWidth, lnHeight) m.oGraphics = Createobject ("gpGraphics") m.oGraphics.CreateFromImage (m.OBitmap) Local tnRed, tnGreen, tnBlue, tnAlpha,xcolor tnRed=Int(255*Rand()) tnGreen=Int(255*Rand()) tnBlue=Int(255*Rand()) m.xcolor=Thisform.rgb2html(Rgb(tnRed,tnGreen,tnBlue)) m.xcolor="0x"+Strtran(m.xcolor,"#","") +"00" &&build a compatible vfp color like 0xAAAA0000 with html color m.oPen = Createobject ("gpPen", 0) For m.nY = 0 To (lnHeight - 1) Step 1 m.oPen.PenColor = Eval(m.xcolor)+ (m.nY * 255 / lnHeight) m.oGraphics.DrawLine (m.oPen, 0, m.nY, lnWidth - 1, m.nY) Endfor m.OBitmap.SaveToFile (m.cFileName, "image/bmp") * can blur result image here with gdiplusX (for a better effect) Thisform.image1.Picture=m.cFileName Thisform.image1.Visible=.T. m.oPen=Null m.oGraphics=Null m.OBitmap=Null Set Classlib To Endproc Procedure shape4.Click **build a elementary bitmap with dimensions in pixels 256x1 With _Screen .AddProperty("red1",0) .AddProperty("green1",0) .AddProperty("blue1",0) .AddProperty("red2",0) .AddProperty("green2",0) .AddProperty("blue2",0) Endwith Local m.xcolor1,m.xcolor2 m.xcolor1=Getcolor() If m.xcolor1=-1 m.xcolor1=255 Endi With _Screen .red1=Asc(Substr(Left(BinToC(m.xcolor1,'R'),3),1,1)) && RED .green1=Asc(Substr(Left(BinToC(m.xcolor1,'R'),3),2,1)) && GREEN .blue1=Asc(Substr(Left(BinToC(m.xcolor1,'R'),3),3,1)) && BLUE Endwith m.xcolor2=Getcolor() If m.xcolor2=-1 m.xclor1=255 Endi With _Screen .red2=Asc(Substr(Left(BinToC(m.xcolor2,'R'),3),1,1)) && RED .green2=Asc(Substr(Left(BinToC(m.xcolor2,'R'),3),2,1)) && GREEN .blue2=Asc(Substr(Left(BinToC(m.xcolor2,'R'),3),3,1)) && BLUE Endwith Local m.X m.X=Int(Val(Inputbox("Gradient horizontal(1)-vertical(2)-diagonam (3)","","2"))) If !Inlist(m.X,1,2,3) m.X=2 Endi Do Case Case m.X=1 * Horizontal m.bmp="BM6"+Chr(3)+Replicate(Chr(0),6)+Chr(0x36)+Replicate(Chr(0),3)+ ; chr(0x28)+Replicate(Chr(0),4)+Chr(1)+Replicate(Chr(0),2)+ ; chr(1)+Replicate(Chr(0),3)+Chr(1)+Chr(0)+Chr(0x18)+Replicate(Chr(0),6)+ ; chr(3)+Replicate(Chr(0),18) For m.i=0 To 255 m.red=Round(_Screen.red1*(255-m.i)/255+_Screen.red2*m.i/255,0) m.blue=Round(_Screen.blue1*(255-m.i)/255+_Screen.blue2*m.i/255,0) m.green=Round(_Screen.green1*(255-m.i)/255+_Screen.green2*m.i/255,0) m.bmp=m.bmp+Chr(m.blue)+Chr(m.green)+Chr(m.red) Next Case m.X=2 * Vertical m.bmp="BM6"+Chr(4)+Replicate(Chr(0),6)+Chr(0x36)+Replicate(Chr(0),3)+ ; chr(0x28)+Replicate(Chr(0),3)+Chr(1)+Replicate(Chr(0),4)+ ; chr(1)+Replicate(Chr(0),2)+Chr(1)+Chr(0)+Chr(0x18)+Replicate(Chr(0),6)+ ; chr(4)+Replicate(Chr(0),18) *!* Vertical For m.i=0 To 255 m.red=Round(_Screen.red1*(255-m.i)/255+_Screen.red2*m.i/255,0) m.blue=Round(_Screen.blue1*(255-m.i)/255+_Screen.blue2*m.i/255,0) m.green=Round(_Screen.green1*(255-m.i)/255+_Screen.green2*m.i/255,0) m.bmp=m.bmp+Chr(m.blue)+Chr(m.green)+Chr(m.red)+Chr(0) Next *!* diagonal Case m.X=3 m.bmp="BM6"+Chr(3)+Replicate(Chr(0),6)+Chr(0x36)+Replicate(Chr(0),3)+ ; chr(0x28)+Replicate(Chr(0),4)+Chr(1)+Replicate(Chr(0),2)+ ; chr(1)+Replicate(Chr(0),3)+Chr(1)+Chr(0)+Chr(0x18)+Replicate(Chr(0),6)+ ; chr(3)+Replicate(Chr(0),18) For m.i=0 To 255 m.red=Round(_Screen.red1*(255-m.i)/255+_Screen.red2*m.i/255,0) m.blue=Round(_Screen.blue1*(255-m.i)/255+_Screen.blue2*m.i/255,0) m.green=Round(_Screen.green1*(255-m.i)/255+_Screen.green2*m.i/255,0) m.bmp=m.bmp+Chr(m.blue)+Chr(m.green)+Chr(m.red) Next Endcase Local m.ytemp m.ytemp=Addbs(Sys(2023))+"bmp"+Sys(2015)+".bmp" Strtofile(m.bmp,m.ytemp) * run/n explorer &ytemp Thisform.image1.Picture=m.ytemp Thisform.image1.Visible=.T. Erase (m.ytemp) Endproc Procedure spinner2.InteractiveChange Thisform.Height=This.Value Try yform.Resize &&yaerot.resize() Catch Endtry Endproc Procedure shape5.Click With _Screen .AddProperty("red1",0) .AddProperty("green1",0) .AddProperty("blue1",0) .AddProperty("red2",0) .AddProperty("green2",0) .AddProperty("blue2",0) Endwith Rand(-1) Local m.xcolor1,m.xcolor2 m.xcolor1=Rgb(255*Rand(),255*Rand(),255*Rand()) &&getcolor() If m.xcolor1=-1 m.xcolor1=255 Endi With _Screen .red1=Asc(Substr(Left(BinToC(m.xcolor1,'R'),3),1,1)) && RED .green1=Asc(Substr(Left(BinToC(m.xcolor1,'R'),3),2,1)) && GREEN .blue1=Asc(Substr(Left(BinToC(m.xcolor1,'R'),3),3,1)) && BLUE Endwith m.xcolor2=Rgb(255*Rand(),255*Rand(),255*Rand()) &&getcolor() If m.xcolor2=-1 m.xclor1=255 Endi With _Screen .red2=Asc(Substr(Left(BinToC(m.xcolor2,'R'),3),1,1)) && RED .green2=Asc(Substr(Left(BinToC(m.xcolor2,'R'),3),2,1)) && GREEN .blue2=Asc(Substr(Left(BinToC(m.xcolor2,'R'),3),3,1)) && BLUE Endwith m.X= Int(3*Rand( ) + 1) &&random 1,2,3 Do Case Case m.X=1 * Horizontal m.bmp="BM6"+Chr(3)+Replicate(Chr(0),6)+Chr(0x36)+Replicate(Chr(0),3)+ ; chr(0x28)+Replicate(Chr(0),4)+Chr(1)+Replicate(Chr(0),2)+ ; chr(1)+Replicate(Chr(0),3)+Chr(1)+Chr(0)+Chr(0x18)+Replicate(Chr(0),6)+ ; chr(3)+Replicate(Chr(0),18) For m.i=0 To 255 m.red=Round(_Screen.red1*(255-m.i)/255+_Screen.red2*m.i/255,0) m.blue=Round(_Screen.blue1*(255-m.i)/255+_Screen.blue2*m.i/255,0) m.green=Round(_Screen.green1*(255-m.i)/255+_Screen.green2*m.i/255,0) m.bmp=m.bmp+Chr(m.blue)+Chr(m.green)+Chr(m.red) Next Case m.X=2 * Vertical m.bmp="BM6"+Chr(4)+Replicate(Chr(0),6)+Chr(0x36)+Replicate(Chr(0),3)+ ; chr(0x28)+Replicate(Chr(0),3)+Chr(1)+Replicate(Chr(0),4)+ ; chr(1)+Replicate(Chr(0),2)+Chr(1)+Chr(0)+Chr(0x18)+Replicate(Chr(0),6)+ ; chr(4)+Replicate(Chr(0),18) *!* Vertical For m.i=0 To 255 m.red=Round(_Screen.red1*(255-m.i)/255+_Screen.red2*m.i/255,0) m.blue=Round(_Screen.blue1*(255-m.i)/255+_Screen.blue2*m.i/255,0) m.green=Round(_Screen.green1*(255-m.i)/255+_Screen.green2*m.i/255,0) m.bmp=m.bmp+Chr(m.blue)+Chr(m.green)+Chr(m.red)+Chr(0) Next Case m.X=3 &&diagonal m.bmp="BM6"+Chr(3)+Replicate(Chr(0),6)+Chr(0x36)+Replicate(Chr(0),3)+ ; chr(0x28)+Replicate(Chr(0),4)+Chr(1)+Replicate(Chr(0),2)+ ; chr(1)+Replicate(Chr(0),3)+Chr(1)+Chr(0)+Chr(0x18)+Replicate(Chr(0),6)+ ; chr(3)+Replicate(Chr(0),18) For m.i=0 To 255 m.red=Round(_Screen.red1*(255-m.i)/255+_Screen.red2*m.i/255,0) m.blue=Round(_Screen.blue1*(255-m.i)/255+_Screen.blue2*m.i/255,0) m.green=Round(_Screen.green1*(255-m.i)/255+_Screen.green2*m.i/255,0) m.bmp=m.bmp+Chr(m.blue)+Chr(m.green)+Chr(m.red) Next Endcase Local m.ytemp m.ytemp=Addbs(Sys(2023))+"bmp"+Sys(2015)+".bmp" Strtofile(m.bmp,m.ytemp) * run/n explorer &ytemp Thisform.image1.Picture=m.ytemp Thisform.image1.Visible=.T. Erase (m.ytemp) Endproc Procedure shape6.Click Wait Window "rightclick to restore" Timeout 0.5 =ylightbox () Endproc Procedure my *LPARAMETERS nButton, nShift, nXCoord, nYCoord Try yform.RemoveObject("yimg") Catch Endtry Endproc Procedure Load Declare SetWindowLong In Win32Api Integer, Integer, Integer Declare SetLayeredWindowAttributes In Win32Api Integer, String, Integer, Integer Declare Integer GetWindowLong In user32; INTEGER HWnd, Integer nIndex Declare Integer SetWindowLong In user32; INTEGER HWnd, Integer nIndex, Integer dwNewLong Declare Integer SetLayeredWindowAttributes In user32; INTEGER HWnd, Integer crKey,; SHORT bAlpha, Integer dwFlags Declare Integer ReleaseCapture In WIN32API Declare Integer SendMessage In WIN32API Integer, Integer, Integer, Integer Do Locfile("system.app") &&put system.app in source folder Endproc Enddefine * *-- EndDefine: yaerot0 *can see my native vfp lightbox with a simlple shape and dramose=9 in *http://yousfi.over-blog.com/2015/03/form-transparencies-in-visual-foxpro.html Function ylightbox() With yform .ShowTips=.T. Try .AddObject("yimg","image") Catch Endtry With .yimg .Left=0 .Top=0 .Width =yform.Width .Height=yform.Height .ZOrder(0) .ToolTipText="Rightclick to restore" .Name="yimg" Endwith Endwith Rand(-1) Local m.xcolor m.xcolor=Rgb(255*Rand(),255*Rand(),255*Rand()) &&can choose a fixed blacky color as rgb(28,28,28) Local RGBChr,red,green,blue m.RGBChr=Left(BinToC(m.xcolor,'R'),3) m.red=Asc(Substr(m.RGBChr,1,1)) m.green=Asc(Substr(m.RGBChr,2,1)) m.blue=Asc(Substr(m.RGBChr,3,1)) With _Screen.System.Drawing loClrMatrix = .Imaging.ColorMatrix.New( ; m.red, 0, 0, 0, 0, ; 0, m.green, 0, 0, 0, ; 0, 0, m.blue, 0, 0, ; 0, 0, 0, 1, 0, ; 0, 0, 0, 0, 1) loBmp = .Bitmap.FromScreen(yform.HWnd,yform.yimg) &&loRect) loBmp.ApplyColorMatrix(loClrMatrix) loGfx = .Graphics.FromImage(loBmp) loGfx.FillRectangle(.SolidBrush.New(.Color.FromARGB(210,m.red, m.green, m.blue)), ; 0, 0, yform.Width, yform.Height) Endwith With yform.yimg .PictureVal = loBmp.GetPictureValFromHBitmap() .ZOrder(0) .Visible = .T. Endwith If Vartype(yform.yimg)="O" Bindevent(yform.yimg,"rightclick",yform1,"my") Endi Endfunc
Click on code to select [then copy] -click outside to deselect
*3* created on Friday 05 of may 2017
*this code builds a button class as container with [label+image+shape].
*images are small pngs encoded strings embed in code (no visual on disc)
*Effects mouseEnter,MouseLeave,click button are binded to procedurs my,my1
*mousemove on any button or click it to see effects.
publi yform
yform=newObject("asup")
yform.show
read events
retu
*
DEFINE CLASS asup AS form
BorderStyle = 0
Height = 377
Width = 555
AutoCenter = .T.
Caption = "Building buttons class -mouseMove or click button"
MaxButton = .F.
BackColor = RGB(0,0,0)
Name = "Form1"
ADD OBJECT container1 AS ybutton WITH ;
Top = 12, ;
Left = 12, ;
Width = 150, ;
Height = 40, ;
BackStyle = 0, ;
BorderWidth = 0, ;
Name = "Container1"
ADD OBJECT container2 AS ybutton WITH ;
Top = 12, ;
Left = 182, ;
Width = 150, ;
Height = 40, ;
BackStyle = 0, ;
BorderWidth = 0, ;
Name = "Container2"
ADD OBJECT container3 AS ybutton WITH ;
Top = 12, ;
Left = 364, ;
Width = 150, ;
Height = 40, ;
BackStyle = 0, ;
BorderWidth = 0, ;
Name = "Container3"
ADD OBJECT container4 AS ybutton WITH ;
Top = 94, ;
Left = 12, ;
Width = 150, ;
Height = 40, ;
BackStyle = 0, ;
BorderWidth = 0, ;
Name = "Container4"
ADD OBJECT container5 AS ybutton WITH ;
Top = 94, ;
Left = 182, ;
Width = 150, ;
Height = 40, ;
BackStyle = 0, ;
BorderWidth = 0, ;
Name = "Container5"
ADD OBJECT container6 AS ybutton WITH ;
Top = 94, ;
Left = 364, ;
Width = 150, ;
Height = 40, ;
BackStyle = 0, ;
BorderWidth = 0, ;
Name = "Container6"
ADD OBJECT container7 AS ybutton WITH ;
Top = 176, ;
Left = 12, ;
Width = 150, ;
Height = 40, ;
BackStyle = 0, ;
BorderWidth = 0, ;
Name = "Container7"
ADD OBJECT container8 AS ybutton WITH ;
Top = 176, ;
Left = 182, ;
Width = 150, ;
Height = 40, ;
BackStyle = 0, ;
BorderWidth = 0, ;
Name = "Container8"
ADD OBJECT container9 AS ybutton WITH ;
Top = 176, ;
Left = 364, ;
Width = 150, ;
Height = 40, ;
BackStyle = 0, ;
BorderWidth = 0, ;
Name = "Container9"
ADD OBJECT container10 AS ybutton WITH ;
Top = 243, ;
Left = 12, ;
Width = 150, ;
Height = 40, ;
BackStyle = 0, ;
BorderWidth = 0, ;
Name = "Container10"
ADD OBJECT container11 AS ybutton WITH ;
Top = 243, ;
Left = 182, ;
Width = 150, ;
Height = 40, ;
BackStyle = 0, ;
BorderWidth = 0, ;
Name = "Container11"
ADD OBJECT container12 AS ybutton WITH ;
Top = 243, ;
Left = 364, ;
Width = 150, ;
Height = 40, ;
BackStyle = 0, ;
BorderWidth = 0, ;
Name = "Container12"
ADD OBJECT spinner1 AS spinner WITH ;
Height = 24, ;
KeyboardHighValue = 160, ;
KeyboardLowValue = 75, ;
Left = 204, ;
SpinnerHighValue = 160.00, ;
SpinnerLowValue = 75.00, ;
Top = 336, ;
Width = 84, ;
Value = 100, ;
Name = "Spinner1"
PROCEDURE INIT
local x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11,x12
*button1.png
text to m.x1 noshow
iVBORw0KGgoAAAANSUhEUgAAAJEAAAAoCAYAAAD+HRieAAABY0lEQVR4nO3cMUpdQRiG4XfOmSgESRVi6RYsFIXsIHcRQloREUFcwE3EHVgJ2YM7uKSQBFKnUwKBC1amOgM6Vnap/Itx4H1W8BWHj/P/w0yqtQJASjPgANgE1pH+bwn8AubU+h0g1Vopw3gGnDaNph6drjw+nKd/45sZcNU6jbr0AOzmKQ37rZOoWyNwnP6uvF0CH1qnUbf+pJvVtdo6hfqWSxpbZ1DnchmG1hnUuTzZRArKJdlEisllsIkUYxMpzCZSWJ5sIgW5J1KYeyKF2UQKczpTWJ6czhRkEynMPZHCbCKF+REpzB9rhdlECnPZqDCPPRRmEyksTzaRgmwihTmdKcxjD4XZRArz8qLC3BMpLJc0LvF5Pb3cbS7D8BOYtU6ibi1ySeNX4BOQWqdRdwowT7VW3m/vnQBfgNw4lPpRgMO7H98u0vMTxO92Pm8BR8BHYKNhOL1ut8ACmN9fX/4GeAKfzVQWOamTqAAAAABJRU5ErkJggg==
endtext
*button2.png
text to m.x2 noshow
iVBORw0KGgoAAAANSUhEUgAAAJEAAAAoCAYAAAD+HRieAAABVUlEQVR4nO3cMUpcURhH8fPmXVNahVhJtiDEQpA0lplFCLYiEgRxAaPiDqwC2UPqNIOdYG055YCVYjH3IjdFsLPyK64Xzm8F/+Jx+Hg83lBr5b9hChwBW8AG0tuWwB0wg3oDMNRayWW8BM6aTlOPzj6tvVwNT89rU+BP6zXq0guwk1Zlcth6ibo1Aicpl/Fb6yXq2m7KZfKl9Qp1bTPlMrYeoc6lXCatN6hzaWWJFGSJFOZNpDBLpDBLpLC0skQKskQK8yZSmCVSmCVSmG+sFWaJFOZNpDBLpDAfIoV5WCvMEinMw1phlkhhlkhhfgqiMEukMG8ihVkihVkihfnGWmGWSGEpl3GJv9fT+y1SLpNbYNp6ibo1T7mMF8APYGi9Rt3JwGyotfJ5b/8UOAdS41HqRwaOH/7+vh5ef0G8/v1gG/gJ7AJfG47Tx7YA5sDscf7rHuAfP0t0ArkjZ/MAAAAASUVORK5CYII=
endtext
*button3.png
text to m.x3 noshow
iVBORw0KGgoAAAANSUhEUgAAAJEAAAAoCAYAAAD+HRieAAABSElEQVR4nO3cMUoDQRxG8Tc4gifQ0itYWAhiY2kuIqiICOIBomJvkYNY2wQ7wdoyCEJQsBJDdsNYiJ2V/2IceL8TfMVjlt2FSaUUABIMgCNgA1hD+t0UeASGBe4BUimF1PVXwHnVaWrReVnO14mPzwFwW3uNmrQAtnLq+oPaS9SsJeA0pdf3KbBae42a9ZzSy1upvUJty3R97Q1qnBEpzIgUlpMRKciTSGFGpDAjUpgRKcyIFJZTt6i9QY3zJFKYESnMiBRmRArzt4fCPIkUZkQKMyKFGZHCMn6xVpBvZwrzcaYwI1KYESnMiBRmRArz7UxhnkQKMyKFZbrFFK/X099NMl3/wPd9jdJfjDNdfwnsAan2GjVnDgxTKYWV3cMz4ALIlUepHXPgeHZ3M0o/VxCv7OxvAifANrBecZz+twkwBoaz8egJ4At6yXX6SIl7EAAAAABJRU5ErkJggg==
endtext
*button4.png
text to m.x4 noshow
iVBORw0KGgoAAAANSUhEUgAAAJEAAAAoCAYAAAD+HRieAAACAUlEQVR4nO3cMWgUQRiG4XeWkTsPMSJG7bURRGwsLUwKBU2hggQLQQu1sJAg0ULUJhBQSAqLIGkULBRRkIAEQQNWIoKQwkpQkWARxIDILTNmLTTHcdflx5sMfk+3yxZf8bLLXTGuqio6OVgPnAIOA4NAo+sh+R+UwFfgLXAXeFZB6HzItUfkQiyAs8B1YHtvdkpGvgBnqnX+efvNVkTuZ7MApoHTvd8mmblZNeqjKxetiIqlH1PAuVSrJDtjy30brsLfiIrF7yeB+4lHSX6GlrdsmnFuYbEBfAT6Ew+S/LwHdntCHEYByersAg55QjyWeolkbcgT4p7UKyRrg96FuDX1CsnaNk+ItdQrJGsbPSGmHiGZU0RipojETBGJmXfhV+oNkjm9icRMEYmZIhIzRSRm3ikiMdKbSMwUkZgpIjFTRGLm0T/WYqRfZ2Kmz5mYKSIxU0RipojE6pMnxG/A5tRLJFufvQvxJXA89RLJ1rwnxEcoIlm9e54QHwMfgB2p10h25suHY69dVVXUjl45ATxIvUiyEoF95ZPxd61DrmpHLo0Dl5POkpyMlDO3JqDjzMbawYs3gGuAS7NLMjFSzk5OrFy4ztNj6wMXDgB3gJ09HiZr3xtgtPni9lz7za6IAOr7zxfAADDMn5j2An3/fqOsMUvAAvAUmAXmmq+muoL5DX0lpCQjNMimAAAAAElFTkSuQmCC
endtext
*button5.png
text to m.x5 noshow
iVBORw0KGgoAAAANSUhEUgAAAJEAAAAoCAYAAAD+HRieAAACDElEQVR4nO3csWtTQQDH8e8Lp6atRAmxdddFkOLiH6BdCtJFQYpDoQ46OAihRBpSY21NpUJLB0HERcFBcCoFEQe7iyAUdFURUSpBi4VI73gO2hCSrYe5Hv4+23u84Tf8eL+bLknTlHZ3a7UeYAw4AwwBvR0fyf/gF/AFeA08BJ5dKZe32j9KWku0NDOTAS4BVeBwd3JKRD4BF69OTb1ofdks0UK1mgEeAOPdzyaRuVOcni5tPzRLNF+p3AMuh0ol0blVmp2twN8S1SYnLwCPA4eS+IyU5+ZWkpsTE73Ae+BQ4EASn3fAcWOdG0UFkp05Bgwb69zZ0EkkaiPGWjsYOoVEbcg45/pDp5CoDRjr3L7QKSRqOWOtDR1CImecc6EzSOSMVYnEk+ZMvGnOxJvmTLxpzsSb/kTiTWci8aY/kXjTmUi8ac7Em+ZMvGnOxJvmTLxpzsSb5ky86U8k3nQmEm+aM/H1wVjn6kA+dBKJ1kfjnHsJnAudRKK1Zqy1T1GJZOceJf2Fwl7gLXAkdBqJztrX9fXBJE1TCvn8eeBJ6EQSFQuc/Favv2lecnUwl7sNXAsaS2JS/L6xsQhtdzbu7+u7AVwHkjC5JBLFn5ubi9sPSfvtsdls9hRwHzja5WCy+70CSo1GY7X1ZUeJAPYYkwFOA6P8KdMJ4MC/zyi7zA/gM7AMPAdWt6ztKMxvSqa/H6MBCvoAAAAASUVORK5CYII=
endtext
*button6.png
text to m.x6 noshow
iVBORw0KGgoAAAANSUhEUgAAAJEAAAAoCAYAAAD+HRieAAADmElEQVR4nO3az2scZRzH8ffzzLNbtzZRIlY9eKoXRYoU/AO0l4IWRFFaD4IKehMUGi9itSAqRSp4sdKLRSn+OIgUVDzYexECgXoQi1WJ0kNtk2w3M/P88DA7m9nutrG7yc5M8n2F7M48+xC+kA/f55nZUeHyZa51/PuTrT8591zKymMOuxfC9oFJYgtQsUL9o4l+bjH16b088N2L+w6mA7OKITpx+pQ+z9xLKywfDoS7J1qvqDyF+muKO154+/EjP/aN5yE6/s1n+lfOnkhJni+lQlEbTW45evSJY7P5eS9Er371yseW+OXSKhO10qT1zgdPf/gGdEN06NShZ9tc+bzswkS9TDGz//2D751W7350ZPsF5n8PhDvLLkrUi0b/sos9D5q/7fkDDicBEjfN4+9f4Ld9pmPbTzpC2fWImmqztN900uXdhmbZtYiausrSXnPVLu/UaBq0MDTKrknUhMeREmNJ7jLe+m0ej2WJCEOTFpqo7BpFRVlSUmI8Nh+aNs763gRHQkJCRANDg2yZU2XUKiok4LHEpCQE/MDnfSHKOWISYkBhMBiaRDRQEqgtxWHzJeuG84xPB0NUlOBIiFGoXoeKaCAdajMKOFIcFkeKH9J1hhnaia7H4ohZKQSqiSZCoUetWpQq4Lv9JguNG+mv3FSIivJAASg0EYaICI3pBks6VRU5XLfbpDgcrMM9QuNHDFG/LM9FuheqiAiDkiu+Ccu6TPbru++WsAE3lkfuRGtxJBSfXlLdfpUFSqPRKFkK10Eg9EJSDMxoS9MojFtjY72+HAzZ6ef7qixYqwHTErCe0I1HuCY0oTtWpnVazsZzo6uA/nBF3bH8R/eO6nq1mIcgC8hqSPqPq/3dpnG22gVm3ev/teZioPqPrx82VXjtHxt+VrT6zw294+y9eDZ8Th6QzWDD9kRi66jEcibqbcIba7EZyXImxibLmRibdCIxNgmRGNuaj4IIsRbpRGJssrEW47pgnPWXgJmyKxG19Ydx1v8EPFV2JaK25o1P/ddIiMToTqrb79nRBM4Bu8quRtTO/L8LS7tVCIHpnbc+A3xRdkWiVizw8OLF9pwBWLzY/nLHTGsP8Hq5dYkamV2+1JkDUCGsPpTWmt72FvAmdX1MUEzKa53F+Fh+0hcigGar8QjwCXDfhAsT1XcWmE066Zni4ECIAEwj0sCjwAGyMD0E3LbxNYqKuQIsAN8CPwBnbOoGAvMfgOKO7LcL9dUAAAAASUVORK5CYII=
endtext
*button7.png
text to m.x7 noshow
iVBORw0KGgoAAAANSUhEUgAAAJEAAAAoCAYAAAD+HRieAAAEAUlEQVR4nO3bTWgcZRzH8e+z++zu7OxLXqhvBy/qRRHxoicPaj0EtCAK0npQqlCrp5JDg1obe4gaCqZgwVgK0qKIICJSsKJgDh4UUQsFPYmtSm0sSfZtdmd2d3Y8PNkm6aZp2E13dvT/gWFnhpnsj/DjP8NMooJCgSu9d/pk+k9+eaaB+6hPczsEdsdB4n9AeQp1MUb8xzS5E7dy1xfPj+1qdBy1ukTHPvsgdoEze+o4kwHBzX3NKwaeQv1lM/rcgcenvlqzv12iox8djy3w0/EW9d2hJBSREcc6fHDX0f3t7cslmnp/z2xA/YXQkolIUVhTr+6ePQDLJZp+96WnCUofhh1MRIwa2THx4jun1Mzh12xqP58jCG4IO5OIGBX/lcz9d2vLPbeThhRIdMO/E/f3MZ1yK0/gB2GnEZFV2qGtSuEeEumwk4io8pa269TCPzcST4A9DCl5pig2qdkAtwRu5SZtuX4KfHAuQjIN+W2QSIUdUQyiIADXAacADbe9N69TbnPlILcMpTJYGcjkIZ2HmAojrhgkvg+VJagUwe9464FO1ZqdJ9WKsFQEpcDOQXYYMjlQsT4kFgPDq0JhAZyimUJXoS13nRKtVluEhUWIxSGbh6FRyA6Zgon/Ft+HahkqJXBKUPc2ddr6k2hdTXAuwfwliGvID8HwNshkQSe6Dy7CEwSmNKUClIrgVjecOFdz7Um0riY4Lvw9bzZTFmRzZlJlc6ZYcukbTNUKFJaguAiVMrRaPf9Idf624a1/0qjUSqnyecgNgZ3Z8q8RG2i1TElqDlSrZr1ShkZ9y79Kzd+S7c/jaq1NmUZGwLbBsiGdNovoXgBUHSiXwHHAqZj1qtPVpakbqjBihfvOIxYzUyqbNeWybUjby5MsG2q0gdFqgeeZYniemSylopksjgPNbm5Jto5yLT24L85iMTOpMhnI5U2ptIZkAhJJsCyzJJIQj+g9mOuaxXHWWa+Z9Ubns5lBogIzEKMvHodkcu2SSJjP9mUzmTTHXXne6n3X2m7zfajXzedm1xuNlfVazSy+f31+H3002JNIRIJ20zrsDCLitGdJiURvZBKJnskkEj3TrpRI9Eh7cjkTPZJJJHomk0j0TG6sRa/Oa9eKLwKjYScRkfWH9tL6G+DJsJOIyDqrXUt/gpRIdO+k9tL6U+A34Paw04jIObt3+rvvVRAEHJl84Cng47ATiUhpAvftO/TtGRUs/wnl9JsPvgVMhBpLRMn4xMtzMwCXSwRw6MgjrwMHAfmnMrGR8cl9X8+0N9aUCOCV2bGHgGPAHX0OJgbfD8D+N/aenlu9s6NEAOMnHosBDwM7MWW6Fxi6/hnFgCkCF4DPgS+BubefPdVRmH8Blit6IEsL4TUAAAAASUVORK5CYII=
endtext
*button8.png
text to m.x8 noshow
iVBORw0KGgoAAAANSUhEUgAAAJEAAAAoCAYAAAD+HRieAAAEO0lEQVR4nO3aS2hcVRzH8e+9cyaZTJqODUoadadYdCFuFLLUghS1LhRKsVCpiLqoKEEiiqQSUUoEq+CiSEAaLD4QF6XUJ9itiFCJD4yk1Bqaxjyax0zmde4cF2feM3FqZiYzN/l/4MLc/9xk/nB/+Z+T4TpmaYkKk5NdjIwcZmbmYaLRvRgTrrxIbHmOkyQQuEo4/BN79pxiePhL+vrSFZcVh0hHoy7PH32Gi1PH0Hr3pjYs2p9S0wwMPKWOj35bXM6HKLmy4nLk8BiLC0da0qDwj939b3d+/NlQ7jQfotihAyeZn3u2ZY0Jf7n5lje7P/zoNciGaPmVl55g4sLpVvclfOa+gf2R4TfOqoXffgnz5+/vElStbkn4za8/jy7MXj2nvE/GD+JwEyrQ6paE32S8Oxkf26f07JXHCEqAxAb9fWm/0rPTdxPZ1epWhF/NXN7rTN3Rm6Az1ElfPxImcd0ScViYg8X5FWfyrhtN/o3uHui/FbrkC2pRjYHlazD/D6zF8lWllVu4JhmDS39AT8ROpcgucN0qv0xsK1rD4hwszkM6ZWtFuSkNUU581R6z09CzEyK9sPMGCdR2sxaD+VlYuQYmu2BVyYvygjWCEV+xx1wAdkRsoHoi4DhN6Fq0lOdBbBWiyxBdgVTS1pUDrH+/q0+iqgzEluwRKApU1w5Q8kWlLxkD8RisLtvgJOOFiQNVp041/yNEJZ9eCBRAsBPC3TZQXd0QCsukaleJOMSyoYnHIJMpvBf474mzng2GqIxJl4bKcWyQQuFCsDpC9X+OuH7GQGINUglIJiC5ZkPj6cI1Lg3Z5yqvESGqJh23x+qCPXcDhVB1hCDYYSdYsKM5n7+dpBLZwCQhFbev08nSpQnskGnC/Va61sa6YQykY/Yo5jg2TB2hQqhU9lyml2UMeGkbDJ22/2Yns1MmnShdknJqbIYbqTHLWb0yKUikIFFWdxxQwUKogp12ouUOFYRA0G70/boH07oQEE/bkOhkaT3jrf/zDVqS6tG85axRjIa0rpxg5RzXBitQFDJXFYVN2fPysDluac11bS3/vlN6nu8rY29uJmMnRcaztVzdGPvay9UNZHShrtM2JOVLTrk2CEktSiuf/gVXMIC2N6rKdG9LAdisJaeZ2mM5E762iRtrsVW1/55ItD1ZzkTdJESibhIiUbfaj4IIUYNMIlE3CZGo11/KU+4i0NvqToRvXVZaud8Dj7e6E+FbE0oH3c+REImNG1dauV8AU8Btre5G+M7EsRe/+8ExxjD8/oMHgE9b3ZHwFQ3cO3L0mwuOyT7P8urJfceBl1valvCTwbee++oEQD5EAENjD70ODLMVHnIRzTQ4+vS5E7mTkhABDJ565H7gA+D2TW5MtL8fgaF3njx7vrhYESKAF04/6gIPAAexYboHiDS/R9FmloErwBnga+D8e4fOVATmX7g0kKqRkxr1AAAAAElFTkSuQmCC
endtext
*button9.png
text to m.x9 noshow
iVBORw0KGgoAAAANSUhEUgAAAJEAAAAoCAYAAAD+HRieAAAEXElEQVR4nO3cf0jcdRzH8ef3e5/Tc7RcTsJokhD2u6GjzOXAjUY4yloEUY3oB2vrhz9yf2xUVMhomyBmW5hbf1TECNYfMyw2ZaNRGtYaiozAFmxOSGObnCV5el+/3/7wvnp33undpd598/04OL3v9/P9ft9/vHh/vt73+1WzvF7idfDkx9lXGdgyga/ExCgwMfOAVWClx70zkSTaOODV0S/pqJ50Mk7ncOuJV8teGo17T7GG6HDLUe0y5x//h78qTCY3AXq8BxMpb9yFal9BZlMud7Xt3LrNimWjmEK0+8vdZaN46y3Mu/9zmcIRdPTulWRXHnhmX+d8Y+cMUe2ndZmD/N5s4H96QSsUjqFI+ySXO6vefrHGF21M1BDtatqTP8xgq4V5+6JVKBxBRz+7mtwn6197fyDS+ogher2h5g4vQ99ZWDmLXqFwBA2tP4ubNx7aVX9p1rrwEL28rzLfy9D3EiARTkPrX82aB5vf+uCPkOXBIdr+TlXmVQZ+kilMRKPh+vlG8kqP7G2YPkdSwQOGfP3NkxgSIDEHo2iQi/uBGnuJZlkWjIxQVvHYQ358p5JYnXAMzVzB9YWtH33VC4FOVLS9WAM+1HGhSEOX7xFFBBZgYjCJX/+bkUNkZpZCoBMVludvBY7bg3Vc6Lhwhc52YpmysALhMbAI+RJ7fXfrhS4FMDFmVIRuZkz/ZgdKx4W2BAWL1GFiMomByWS0IZVAl5ZfsiYb+JN5r4Vp6OiBQOkgkfofsjAD0bEww7tOJKNAtvKPGVtI4GKqHSZNzp8cbWqqijk04a4DSpXfZ5QkdviZKU+bfunTn6RTpaqpXmMF4rMA1qkJn1GwEHsKpwW9QA/8FEvHCnSWmfcFCk24AuUfM25ZjD1HYncoO1ASrIVhT0PBoSH+qSlRa5XfZ9ywVEeby0ygtFnvYkroOcuShyWaLM3tUUmvIjbLp2+lSDhiZWo4qFqRksaV26PGAbnBXiTKq9Iy1DBwU7IrEY41rNwedRkJkUhcr3JnqB7ggWRXIhyrR6V51GlgZ7IrEY7VqdwedQKQk2uRiCvAj+riucHR2zbktgPlya5IOE7Lbx0DkwrA7VFNSIhE/BrBvscaKCzPPwesS2ZFwlHaulsvlEHQ0x5uj6oEOpALVmJ+E0C1/WG6EwGUPHfPYWBHEooSzrK384vz79ofQu7ET8tQ1UAhcP9SVyUcox2oDV4Q0okAHq66Lxf4AViy+4yEY/QBJe0Hf7kWvHBWiAAe2VOcB5xBgiRm9AGbvq3rGgxfETFEAE+8tyEH+BooWtzahAO0A88er+24Fmll1BABPLV/YzpwAKhC/r3ecjQB1AG1x948E/XhszlDZNvWuPleoAHYvGDliVTXBlQffeNU33wDYwqR7YXmsmKmnnosB1YmXJ5IVVeAFqDxs1dO/hrrRnGFyLbj80fTgfVAMVAArAWygFXIhVwnGAe8wDDQC/Qw9YfU2SPPfxN12ormX2xhaSrPLQhHAAAAAElFTkSuQmCC
endtext
*button10.png
text to m.x10 noshow
iVBORw0KGgoAAAANSUhEUgAAAJEAAAAoCAYAAAD+HRieAAAEtElEQVR4nO2cf2hVVRzAP+e+S29mazZWzigSYlREMoVMW7Dsl7NYDQKVFoqSs8JtCC7EWmSzVFyxFqy5lWEwMP/JlNKtrCwNS6IxKNhfaYNkbI4n0/betndOf7x7t/ue723vzffrrvOByzv3nHPv/T7eh+89995zn1A+H4nSfOKjgkH6Vo3iL5GMF0vkQmAeKG/CO9NkCBEAfAbGeQOz28uck4XcffyVso1XEt5TvBK1HekQffzxnJ/hLUHGVwBGogfTZDsi4MHsmsPNLXdwX2dVRaWKa6t4JHr98x1l/+JrVMj7rztOjSsQeH7PJb/67TUNZ6btO5VE7xxszBvkr9YgY2uTGqHGNZjc0H4bRTXb19f6Y/WJKdGOtvqiYfqPKdQ9KYtQ4woExrk8Fjy/q+qtvqjt0SSqa95+71UGvgdVmPIINS5BXMhl/qN7a949f01LpERb99UVjTD4o9ICaSIQiAtzmf/we3V7/gmrd0pU0/Ba3gj9v+hTmCYWAvHrXG4vbarfPTFGMp0drgb6WxVBLZBmKpYOc3E3sNWuEEopuHyZDdvWPa4Y+zaDwWncgzS4cfGBxk96wMpEL1ZXCOCD0P1DDyAyGJ8mu5FA0ICRD8nLKwUrE1WuLq0AvpjsaIAwQp9aKA0KCIKSVnmC5R2HT501AaRfbgnfSE4WhSWU8KQ6Uk22oSQoW56oVANnxZqnSgqAfuJ5FiYMMDxWltLMSpR0LNM+OrsCFJjSL1cR98NUCYyHioYHDCO0aNyLUiCDIOOSJpKbgFJTBVTJzI4+PlkUwhJKWNlKi5W1KAlBGZJGxjxNJcISU/plcTL2BMHwVVsqjyWV0AP0tCNVSBqpLGnUTLLNdBSbKqDuSvZeQ0RIJQjJZEtlCCuDabmuG1sQqRxZJumyxGKRKf3ylnQdLeyqz8lExhKOxRYtfdFlLQpr7KIiZLEyTNp8iUq+qQLZMKVVMbVgDsmEJZZwCCfAtbZFyhFtSf4pKJncakp/UgZXmccWSwjrHqmjPCFbjMzmHK9Ftsfaxs4OkZ8weSoJa3OUcQoy0y+cNYyZRo4RALIgGyUb65ezbrZGDtHSjiBcRk9khWvxmcIrhoAFmY5E41qGTCPH+BstkWbm9JjCK7qBhzIdica1dJtGjnES2JzpSDSu5YwpvOI4MEsH15oUMwD8LJRSrF35yFGgPNMRaVxH+6HO01UmgPCKFrREmsRpAnuONVC5uvQ3YEkmI9K4is6Ow6fKwPG2h8gxqoHTzJI7YJqUMgrU2isTmQhg3abH9gNVGQhK4y4aPmv/7k17Jey9M5Fj1AKLgQfTHZXGNXQBO50VYZkIYMO2J+8EfgJSNM9I42J6gZJPG7+55Ky8RiKAjW+sXAj8gBZJM0kvsOLArs6LkQ1RJQJ4qaGsEPgSWJra2DQuoAt44eP6E5eiNcaUCGDTvqe9wB6gBv33ev9HRoG9wM72uq9jTqaZUiKbzc3PPAC8DzyRtPA02U4nULu/5qve6TrGJZHNy23lywi99VgO5M44PE22MgAcAZpaq479Ge9GCUlk8+rBZ73AcmAZUAwsAvKBeegHuW4gAPiAIaAH6CZ0IXWuZf3RhOeA/geXCqymE+9zkwAAAABJRU5ErkJggg==
endtext
*button11.png
text to m.x11 noshow
iVBORw0KGgoAAAANSUhEUgAAAJQAAAAoCAYAAAAYNNPaAAABwElEQVR4nO3cMUscURTF8f9k7iQoogMWEmystIkfwC6IkCKmsFAJaCPERUiTj5HGymabBQkYgqBFgoVtLC0t7NRGEoigsiBmZhgLsxKwCXrhZR/n105zisM7U92krms6rr6+fw40gEVgGHiGyH0XwCGwA6z2vFlrdz4knUK1txvTwBegN0RC6Vo/gHd9M81v8KdQ55tLC8A68CRoNOlW18BUPtvaS35tLOTAMTAQNpN0uTNgxKqi+IDKJI83CMxZVRZToZNINFasLIsXoVNINEatKov+0CkkGv1WlUXoEBIRK1UocaQXSlxZVfwOnUEioskTV5o8caVCiSsVSlzpH0pcWVWoUOJHkyeuNHniSi+UuLLUstAZJCJmKpQ40gslrizNVCjxo8kTV5o8caVCiSsVSlzpH0pcWZo9DZ1BIqLJE1eaPHFlqWXX6LCY+Dix1LJjYCx0EonCvpllLeBj6CQShd3k5/p8DhwBeeg00tUOgfGkrmvOPi9OcnuAU/9S8hCXwPTg20/f7462nm8uvQaa3F7/FflXp8CrfLZ1AH9dAQZobzd6gGVgAngJDAUIKP+/C+AAWAO2+maadwcybgDQIHzWrpJYGwAAAABJRU5ErkJggg==
endtext
*button12.png
text to m.x12 noshow
iVBORw0KGgoAAAANSUhEUgAAAJEAAAAoCAYAAAD+HRieAAACDElEQVR4nO3csWtTQQDH8e8Lp6atRAmxdddFkOLiH6BdCtJFQYpDoQ46OAihRBpSY21NpUJLB0HERcFBcCoFEQe7iyAUdFURUSpBi4VI73gO2hCSrYe5Hv4+23u84Tf8eL+bLknTlHZ3a7UeYAw4AwwBvR0fyf/gF/AFeA08BJ5dKZe32j9KWku0NDOTAS4BVeBwd3JKRD4BF69OTb1ofdks0UK1mgEeAOPdzyaRuVOcni5tPzRLNF+p3AMuh0ol0blVmp2twN8S1SYnLwCPA4eS+IyU5+ZWkpsTE73Ae+BQ4EASn3fAcWOdG0UFkp05Bgwb69zZ0EkkaiPGWjsYOoVEbcg45/pDp5CoDRjr3L7QKSRqOWOtDR1CImecc6EzSOSMVYnEk+ZMvGnOxJvmTLxpzsSb/kTiTWci8aY/kXjTmUi8ac7Em+ZMvGnOxJvmTLxpzsSb5ky86U8k3nQmEm+aM/H1wVjn6kA+dBKJ1kfjnHsJnAudRKK1Zqy1T1GJZOceJf2Fwl7gLXAkdBqJztrX9fXBJE1TCvn8eeBJ6EQSFQuc/Favv2lecnUwl7sNXAsaS2JS/L6xsQhtdzbu7+u7AVwHkjC5JBLFn5ubi9sPSfvtsdls9hRwHzja5WCy+70CSo1GY7X1ZUeJAPYYkwFOA6P8KdMJ4MC/zyi7zA/gM7AMPAdWt6ztKMxvSqa/H6MBCvoAAAAASUVORK5CYII=
endtext
with thisform
for i=1 to .controlcount
if lower(.controls(i).name)=="container"+trans(i)
with .controls(i).label1
dodefault()
.fontsize=9
.fontunderline=.t.
.width=100
.height=40
.left=(.parent.width-.width)/2
.top=(.parent.height-.height)/2
.caption="Command"+trans(i)
endwith
m.y=eval("x"+trans(i))
with .controls(i)
.image1.pictureVal=strconv(m.y,14)
.image1.backstyle=0
.shape1.backcolor=rgb(255*rand(),255*rand(),255*rand())
.shape1.backstyle=1
bindevent(.shape1,"mouseEnter",thisform,"my")
bindevent(.shape1,"mouseLeave",thisform,"my1")
.refresh
endwith
endi
endfor
endwith
PROCEDURE my
LPARAMETERS nButton, nShift, nXCoord, nYCoord
*--- aevent create an array laEvents
Aevents( myArray, 0)
*--- reference the calling object
loObject = myArray[1]
DoDefault()
loObject.backstyle=0
ENDPROC
PROCEDURE my1
LPARAMETERS nButton, nShift, nXCoord, nYCoord
*--- aevent create an array laEvents
Aevents( myArray, 0)
*--- reference the calling object
loObject = myArray[1]
DoDefault()
loObject.backstyle=1
ENDPROC
PROCEDURE spinner1.InteractiveChange
with thisform
for i=1 to .controlcount
if lower(.controls(i).name)== "container" +trans(i) &&container"
with .controls(i)
.width=this.value
.label1.left=(.width-.label1.width)/2
.label1.top=(.height-.label1.height)/2
.refresh
endwith
endi
endfor
endwith
ENDPROC
Procedure destroy
clea events
endproc
ENDDEFINE
*
*-- EndDefine: asup
*
DEFINE CLASS ybutton AS container
Top = 12
Left = 12
Width = 150
Height = 40
BackStyle = 0
BorderWidth = 0
Name = "Container1"
ADD OBJECT shape1 AS shape WITH ;
Top = 0, ;
Left = 0, ;
Height = 61, ;
Width = 193, ;
Anchor = 15, ;
BackStyle = 0, ;
BorderWidth = 1, ;
Curvature = 15, ;
MousePointer = 15, ;
Name = "Shape1"
ADD OBJECT image1 AS image WITH ;
Stretch = 2, ;
Height = 100, ;
Left = -5, ;
Top = -12, ;
Width = 240, ;
Name = "Image1"
ADD OBJECT label1 AS label WITH ;
AutoSize = .T., ;
FontBold = .T., ;
FontSize = 12, ;
Alignment = 2, ;
BackStyle = 0, ;
Caption = "Actions to code", ;
Height = 22, ;
Left = 36, ;
MousePointer = 15, ;
Top = 12, ;
Width = 121, ;
ForeColor = RGB(0,255,0), ;
Name = "Label1"
PROCEDURE shape1.Click
messagebox("do some code from here",0+32+4096,"",1000)
ENDPROC
PROCEDURE shape1.Init
with this
.left=0
.top=0
.width=.parent.width
.height=.parent.height
.zorder(0)
.curvature=10
.mousepointer=15
.borderwidth=1
endwith
ENDPROC
PROCEDURE shape1.MouseEnter
LPARAMETERS nButton, nShift, nXCoord, nYCoord
this.parent.image1.visible=.t.
this.borderStyle=0
ENDPROC
PROCEDURE shape1.MouseLeave
LPARAMETERS nButton, nShift, nXCoord, nYCoord
this.parent.image1.visible=.f.
this.borderStyle=1
ENDPROC
PROCEDURE image1.Init
with this
.anchor=15
.left=0
.top=0
.width=.parent.width
.height=.parent.height
.stretch=2
.visible=.f.
.zorder(1)
endwith
ENDPROC
PROCEDURE image1.Click
with this
.anchor=15
.stretch=2
.left=0
.top=0
.width=.parent.width0
.height=.parent.height0
.zorder(1)
endwith
ENDPROC
PROCEDURE label1.Click
this.parent.shape1.click()
ENDPROC
PROCEDURE label1.MouseLeave
LPARAMETERS nButton, nShift, nXCoord, nYCoord
this.parent.shape1.mouseLeave()
ENDPROC
PROCEDURE label1.MouseEnter
LPARAMETERS nButton, nShift, nXCoord, nYCoord
this.parent.shape1.mouseEnter()
ENDPROC
PROCEDURE label1.Init
with this
.left=(.parent.width-.width)/2
.top=(.parent.height-.height)/2
.zorder(0)
endwith
ENDPROC
ENDDEFINE
*
*-- EndDefine: ybutton
Click on code to select [then copy] -click outside to deselect
*4* Created on saturday 06 of may 2017
*!* this code build a basic special menu (similar to office)
*!* it uses 2 containers one for the header and another for the menu
*!* 2 images are used ans transparent shapes to accomplish the goal instead
*!* of building complex classes for each component.its very easy to do for the common of mortals.
!*! see also the special effect i used in shape to highLight any menu option.
*!* its a simple demo ,can customize all what can be customizable in the class and adapt images to the context.
set defa to addbs(justpath(sys(16,1)))
local m.ydownl
m.ydownl=.t. &&put it to .t. first time only-once images downloaded put it to .f.
if m.ydownl=.t.
*first download 2 images used in code
*download the picture used in code.if dont have internet connect , replace by a local image named yimage.jpg
Declare Integer URLDownloadToFile In urlmon.Dll Integer pCaller, String szURL, String szFileName, Integer dwReserved, Integer lpfnCB
Declare Integer DeleteUrlCacheEntry In wininet String lpszUrlName
Local lcDownloadURL,lcDownloadLoc,lnResult
for i=1 to 2
do case
case i=1
lcDownloadURL = "http://img.over-blog-kiwi.com/1/43/54/07/20170506/ob_b85844_yword-menu.png"
lcDownloadLoc = "yword_menu.png"
case i=2
lcDownloadURL = "http://img.over-blog-kiwi.com/1/43/54/07/20170506/ob_59cf6b_yword-menu0.png"
lcDownloadLoc = "yword_menu0.png"
endcase
lnResult = DeleteUrlCacheEntry(lcDownloadURL)
lnResult = URLDownloadToFile(0, lcDownloadURL, lcDownloadLoc , 0,0)
If lnResult = 0
Wait Window "Download yimage.jpg Complete" nowait
*Else
*!* Messagebox("Download fails")
Endi
endfor
endi
Publi yform
yform=Newobject("ymenu")
yform.Show
Read Events
Retu
*
Define Class ymenu As Form
Height = 523
Width = 689
ShowWindow = 2
AutoCenter = .T.
Caption = "A special menu with containers"
BackColor = Rgb(212,210,208)
Name = "Form1"
Add Object ycnt1 As cnt1 With ;
Top = 55, ;
Left = 8, ;
Width = 408, ;
Height = 432, ;
BackStyle = 0, ;
BorderWidth = 0, ;
Visible = .F., ;
Name = "ycnt1"
Add Object ycnt0 As cnt0 With ;
Top = 8, ;
Left = 7, ;
Width = 401, ;
Height = 48, ;
BackStyle = 0, ;
BorderWidth = 0, ;
Name = "ycnt0"
Procedure my
Lparameters nButton, nShift, nXCoord, nYCoord
*--- aevent create an array laEvents
Aevents( myArray, 0)
*--- reference the calling object
loObject = myArray[1]
loObject.Parent.label1.ForeColor=Rgb(255*Rand(),255*Rand(),255*Rand())
Local N
N=Int(Val(Substr(loObject.Name,6)))
If ! N=9
loObject.Parent.label1.Caption="Run some codes from here!"
Else
loObject.Parent.Visible=.F.
Endi
Endproc
Procedure my1
Lparameters nButton, nShift, nXCoord, nYCoord
*--- aevent create an array laEvents
Aevents( myArray, 0)
*--- reference the calling object
loObject = myArray[1]
With loObject
.DrawMode=9
.BackColor=255
.BackStyle=1
.Curvature=15
Endwith
Local N
N=Int(Val(Substr(loObject.Name,6)))
loObject.Parent.label1.ForeColor=Rgb(255*Rand(),255*Rand(),255*Rand())
loObject.Parent.label1.FontSize=24
Do Case
Case Between( N,1,8)
loObject.Parent.label1.FontSize=24
loObject.Parent.label1.Caption="Menu"+Substr(loObject.Name,6)+" clicked!"+Chr(13)+"Can run some code frome here..."
Case N=9
loObject.Parent.label1.FontSize=24
loObject.Parent.label1.Caption="Close the menu"
Case N=10
TEXT to m.myvar noshow
Lorem ipsum dolor sit amet, consectetur adipiscing elit. Proin vel risus eget lorem feugiat
fermentum nec a turpis. Phasellus purus sem, mollis ac posuere eget, ornare vel orci.
ENDTEXT
loObject.Parent.label1.FontSize=14
loObject.Parent.label1.Caption=m.myvar
Endcase
Endproc
Procedure my2
Lparameters nButton, nShift, nXCoord, nYCoord
*--- aevent create an array laEvents
Aevents( myArray, 0)
*--- reference the calling object
loObject = myArray[1]
loObject.DrawMode=13
loObject.BackStyle=0
loObject.Parent.label1.Caption=""
Endproc
Procedure Destroy
Clea Events
Endproc
Enddefine
*
*-- EndDefine: ymenu
*
Define Class cnt1 As Container
Top = 55
Left = 8
Width = 408
Height = 432
BackStyle = 0
BorderWidth = 0
Visible = .F.
Name = "ycnt1"
Add Object image1 As Image With ;
Picture = "yword_menu.png", ;
Stretch = 0, ;
Height = 424, ;
Left = 0, ;
Top = 0, ;
Width = 400, ;
Name = "Image1"
Add Object image2 As Image With ;
Picture = "", ;
Stretch = 2, ;
Height = 46, ;
Left = 118, ;
Top = 7, ;
Width = 277, ;
Name = "Image2"
Add Object shape1 As Shape With ;
Top = 6, ;
Left = 6, ;
Height = 36, ;
Width = 85, ;
BackStyle = 0, ;
BorderStyle = 0, ;
BorderWidth = 0, ;
MousePointer = 15, ;
Name = "Shape1"
Add Object shape2 As Shape With ;
Top = 97, ;
Left = 9, ;
Height = 37, ;
Width = 85, ;
BackStyle = 0, ;
BorderStyle = 0, ;
MousePointer = 15, ;
Name = "Shape2"
Add Object shape3 As Shape With ;
Top = 49, ;
Left = 7, ;
Height = 37, ;
Width = 85, ;
BackStyle = 0, ;
BorderStyle = 0, ;
MousePointer = 15, ;
Name = "Shape3"
Add Object shape4 As Shape With ;
Top = 136, ;
Left = 11, ;
Height = 37, ;
Width = 90, ;
BackStyle = 0, ;
BorderStyle = 0, ;
MousePointer = 15, ;
Name = "Shape4"
Add Object shape5 As Shape With ;
Top = 180, ;
Left = 11, ;
Height = 37, ;
Width = 90, ;
BackStyle = 0, ;
BorderStyle = 0, ;
MousePointer = 15, ;
Name = "Shape5"
Add Object shape6 As Shape With ;
Top = 224, ;
Left = 13, ;
Height = 37, ;
Width = 90, ;
BackStyle = 0, ;
BorderStyle = 0, ;
MousePointer = 15, ;
Name = "Shape6"
Add Object shape7 As Shape With ;
Top = 265, ;
Left = 11, ;
Height = 37, ;
Width = 94, ;
BackStyle = 0, ;
BorderStyle = 0, ;
MousePointer = 15, ;
Name = "Shape7"
Add Object shape8 As Shape With ;
Top = 310, ;
Left = 4, ;
Height = 37, ;
Width = 108, ;
BackStyle = 0, ;
BorderStyle = 0, ;
MousePointer = 15, ;
Name = "Shape8"
Add Object shape9 As Shape With ;
Top = 351, ;
Left = 9, ;
Height = 37, ;
Width = 90, ;
BackStyle = 0, ;
BorderStyle = 0, ;
MousePointer = 15, ;
Name = "Shape9"
Add Object shape10 As Shape With ;
Top = 393, ;
Left = 216, ;
Height = 25, ;
Width = 180, ;
BackStyle = 0, ;
BorderStyle = 0, ;
Name = "Shape10"
Add Object label1 As Label With ;
FontSize = 24, ;
WordWrap = .T., ;
BackStyle = 0, ;
Caption = "", ;
Height = 228, ;
Left = 120, ;
Top = 84, ;
Width = 276, ;
ForeColor = Rgb(128,0,64), ;
Name = "Label1"
Add Object image3 As Image With ;
Picture = "", ;
Stretch = 2, ;
Height = 46, ;
Left = 118, ;
Top = 346, ;
Width = 277, ;
Name = "Image3"
Procedure Init
local m.myv
text to m.myv noshow
iVBORw0KGgoAAAANSUhEUgAAAJEAAAAoCAYAAAD+HRieAAAEO0lEQVR4nO3aS2hcVRzH8e+9cyaZTJqODUoadadYdCFuFLLUghS1LhRKsVCpiLqoKEEiiqQSUUoEq+CiSEAaLD4QF6XUJ9itiFCJD4yk1Bqaxjyax0zmde4cF2feM3FqZiYzN/l/4MLc/9xk/nB/+Z+T4TpmaYkKk5NdjIwcZmbmYaLRvRgTrrxIbHmOkyQQuEo4/BN79pxiePhL+vrSFZcVh0hHoy7PH32Gi1PH0Hr3pjYs2p9S0wwMPKWOj35bXM6HKLmy4nLk8BiLC0da0qDwj939b3d+/NlQ7jQfotihAyeZn3u2ZY0Jf7n5lje7P/zoNciGaPmVl55g4sLpVvclfOa+gf2R4TfOqoXffgnz5+/vElStbkn4za8/jy7MXj2nvE/GD+JwEyrQ6paE32S8Oxkf26f07JXHCEqAxAb9fWm/0rPTdxPZ1epWhF/NXN7rTN3Rm6Az1ElfPxImcd0ScViYg8X5FWfyrhtN/o3uHui/FbrkC2pRjYHlazD/D6zF8lWllVu4JhmDS39AT8ROpcgucN0qv0xsK1rD4hwszkM6ZWtFuSkNUU581R6z09CzEyK9sPMGCdR2sxaD+VlYuQYmu2BVyYvygjWCEV+xx1wAdkRsoHoi4DhN6Fq0lOdBbBWiyxBdgVTS1pUDrH+/q0+iqgzEluwRKApU1w5Q8kWlLxkD8RisLtvgJOOFiQNVp041/yNEJZ9eCBRAsBPC3TZQXd0QCsukaleJOMSyoYnHIJMpvBf474mzng2GqIxJl4bKcWyQQuFCsDpC9X+OuH7GQGINUglIJiC5ZkPj6cI1Lg3Z5yqvESGqJh23x+qCPXcDhVB1hCDYYSdYsKM5n7+dpBLZwCQhFbev08nSpQnskGnC/Va61sa6YQykY/Yo5jg2TB2hQqhU9lyml2UMeGkbDJ22/2Yns1MmnShdknJqbIYbqTHLWb0yKUikIFFWdxxQwUKogp12ouUOFYRA0G70/boH07oQEE/bkOhkaT3jrf/zDVqS6tG85axRjIa0rpxg5RzXBitQFDJXFYVN2fPysDluac11bS3/vlN6nu8rY29uJmMnRcaztVzdGPvay9UNZHShrtM2JOVLTrk2CEktSiuf/gVXMIC2N6rKdG9LAdisJaeZ2mM5E762iRtrsVW1/55ItD1ZzkTdJESibhIiUbfaj4IIUYNMIlE3CZGo11/KU+4i0NvqToRvXVZaud8Dj7e6E+FbE0oH3c+REImNG1dauV8AU8Btre5G+M7EsRe/+8ExxjD8/oMHgE9b3ZHwFQ3cO3L0mwuOyT7P8urJfceBl1valvCTwbee++oEQD5EAENjD70ODLMVHnIRzTQ4+vS5E7mTkhABDJ565H7gA+D2TW5MtL8fgaF3njx7vrhYESKAF04/6gIPAAexYboHiDS/R9FmloErwBnga+D8e4fOVATmX7g0kKqRkxr1AAAAAElFTkSuQmCC
endtext
this.image2.pictureVal=strconv(m.myv,14)
this.image3.pictureVal=strconv(m.myv,14)
With This
For i=1 To .ControlCount
If Lower(.Controls(i).Class)=="shape"
Bindevent(.Controls(i),"mousedown",Thisform,"my")
Bindevent(.Controls(i),"mouseEnter",Thisform,"my1")
Bindevent(.Controls(i),"mouseLeave",Thisform,"my2")
Endi
Endfor
Endwith
Endproc
Enddefine
*enddefine cnt1
*
Define Class cnt0 As Container
Top = 8
Left = 7
Width = 401
Height = 48
BackStyle = 0
BorderWidth = 0
Name = "ycnt0"
Add Object image1 As Image With ;
Picture = "yword_menu0.png", ;
Stretch = 0, ;
Height = 47, ;
Left = 0, ;
Top = 0, ;
Width = 400, ;
Name = "Image1"
Add Object shape1 As Shape With ;
Top = 0, ;
Left = 0, ;
Height = 49, ;
Width = 45, ;
BackStyle = 0, ;
BorderStyle = 0, ;
BorderWidth = 0, ;
MousePointer = 15, ;
Name = "Shape1"
Add Object shape2 As Shape With ;
Top = 0, ;
Left = 50, ;
Height = 25, ;
Width = 121, ;
BackStyle = 0, ;
BorderStyle = 0, ;
Name = "Shape2"
Add Object spinner1 As Spinner With ;
BorderStyle = 1, ;
Height = 24, ;
Left = 369, ;
MousePointer = 15, ;
Top = 8, ;
Width = 21, ;
BorderColor = Rgb(100,100,100), ;
Name = "Spinner1"
Procedure shape1.Click
Thisform.ycnt1.Visible=Iif(Thisform.ycnt1.Visible=.F.,.T.,.F.)
Endproc
Procedure shape2.Click
Messagebox("no option coded here",0+232+4096,1200)
Endproc
Procedure spinner1.UpClick
If Thisform.ycnt1.Visible=.T.
Thisform.ycnt1.Visible=.F.
Endi
Endproc
Procedure spinner1.DownClick
If Thisform.ycnt1.Visible=.F.
Thisform.ycnt1.Visible=.T.
Endi
Endproc
Enddefine
*
*-- EndDefine: cnt0
Click on code to select [then copy] -click outside to deselect
*5* created on monday 08 of may 2017 -updated on 10 of may 2017
*!* this code builds another special menu with a simple image positionned in a container and overlapped with some shapes.
*!* adding a shape with each menu item and playing with shape drawMode property and bindevent() function.
*!* can build as well any modern menu (even office Ribbons with simple image !...)
*!* images here are loaded with no disc access (from the web store)-i made 4 images styles(to change with spnner1).
*!* added a button to collapse/expand the built menu (as bootstrap navigation does)
Publi m.yrep
m.yrep=Addbs(Justpath(Sys(16,1)))
Set Defa To (yrep)
Publi yform
yform=Newobject("Smenu")
yform.Show
Read Events
Retu
*
Define Class Smenu As Form
Height = 500
Width = 919
ShowWindow = 2
AutoCenter = .T.
Caption = "A special menu with shape drawmode effect.click on menu button (o collapse/expand menu (as bootstrap)."
BackColor = Rgb(212,210,208)
Name = "Form1"
xleft=0
xwidth=0
ycl=0
Add Object container1 As ycont With ;
Top = 0, ;
Left = 12, ;
Width = 192, ;
Height = 500, ;
BackStyle = 0, ;
BorderWidth = 0, ;
Name = "Container1"
Add Object "yec1" As "yec" With ;
visible=.T.,;
name="yec"
Add Object label1 As Label With ;
AutoSize = .T., ;
FontBold = .T., ;
FontSize = 32, ;
BackStyle = 0, ;
Caption = "Do some code from here !", ;
Height = 54, ;
Left = 300, ;
Top = 120, ;
Visible = .F., ;
Width = 531, ;
ForeColor = Rgb(128,0,64), ;
Name = "Label1"
Add Object label2 As Label With ;
AutoSize = .T., ;
FontBold = .T., ;
FontSize = 32, ;
BackStyle = 0, ;
Caption = "Do some code from here !", ;
Height = 54, ;
Left = 295, ;
Top = 124, ;
Visible = .F., ;
Width = 531, ;
ForeColor = Rgb(0,255,0), ;
Name = "Label2"
Add Object label3 As Label With ;
FontSize = 11, ;
BackStyle = 0, ;
Caption = "Label3", ;
Height = 73, ;
Left = 300, ;
Top = 348, ;
Width = 589, ;
ForeColor = Rgb(128,0,64), ;
wordwrap=.T., ;
Name = "Label3"
Add Object label4 As Label With ;
AutoSize = .T., ;
FontBold = .T., ;
FontSize = 16, ;
BackStyle = 0, ;
Caption = "", ;
Height = 27, ;
Left = 468, ;
Top = 36, ;
Visible = .F., ;
Width = 2, ;
ForeColor = Rgb(255,0,0), ;
Name = "Label4"
Procedure my
Lparameters nButton, nShift, nXCoord, nYCoord
*--- aevent create an array laEvents
Aevents( myArray, 0)
*--- reference the calling object
loObject = myArray[1]
Local m.x
m.x=Substr(loObject.Name,6)
Set Curs Off
With Thisform
.label1.Visible=.T.
.label2.Visible=.T.
.label4.Caption="Item"+Trans(m.x)+" clicked."
.label4.Visible=.T.
Endwith
Endproc
Procedure my1
Lparameters nButton, nShift, nXCoord, nYCoord
*mouseEnter
*--- aevent create an array laEvents
Aevents( myArray, 0)
*--- reference the calling object
loObject = myArray[1]
With loObject
.BackStyle=1
Endwith
Endproc
Procedure my2
Lparameters nButton, nShift, nXCoord, nYCoord
*--- aevent create an array laEvents
Aevents( myArray, 0)
*--- reference the calling object
loObject = myArray[1]
With loObject
.BackStyle=0
Endwith
With Thisform
.label1.Visible=.F.
.label2.Visible=.F.
.label4.Visible=.F.
Endwith
Set Curs On
Endproc
Procedure Destroy
Clea Events
Endproc
Procedure container1.Init
With This.image1
.Left=0
.Top=0
.Stretch=0
.ZOrder(1)
Endwith
This.SetAll("mousepointer",15,"shape")
For i=1 To 13
With Eval("this.shape"+Trans(i))
.BorderStyle=0
.BackStyle=0
.DrawMode=9
.BackColor=255
.Curvature=15
.ZOrder(0)
Endwith
Bindevent(Eval("this.shape"+Trans(i)),"mouseDown",Thisform,"my")
Bindevent(Eval("this.shape"+Trans(i)),"mouseEnter",Thisform,"my1")
Bindevent(Eval("this.shape"+Trans(i)),"mouseLeave",Thisform,"my2")
Endfor
This.spinner1.InteractiveChange()
Endproc
Procedure label3.Init
TEXT to this.caption noshow
with a simple image designed as decorated menu ,can place it in a container
and cover subtitles with shapes with particular properties as mouseEnter/mouseLeave and the function bindevent().
-can simulate any modern menu with this trick.
ENDTEXT
Endproc
Enddefine
*
*-- EndDefine:smenu
Define Class ycont As Container
Top = 0
Left = 12
Width = 192
Height = 480
BackStyle = 0
BorderWidth = 0
Name = "ycont"
Add Object image1 As Image With ;
Picture = "ylist0.png", ;
BackStyle = 0, ;
Height = 425, ;
Left = 0, ;
Top = 0, ;
Width = 183, ;
Name = "Image1"
Add Object shape1 As Shape With ;
Top = 59, ;
Left = 6, ;
Height = 25, ;
Width = 169, ;
Name = "Shape1"
Add Object shape2 As Shape With ;
Top = 85, ;
Left = 6, ;
Height = 25, ;
Width = 169, ;
Name = "Shape2"
Add Object shape3 As Shape With ;
Top = 111, ;
Left = 5, ;
Height = 25, ;
Width = 169, ;
Name = "Shape3"
Add Object shape4 As Shape With ;
Top = 139, ;
Left = 6, ;
Height = 25, ;
Width = 169, ;
Name = "Shape4"
Add Object shape5 As Shape With ;
Top = 165, ;
Left = 4, ;
Height = 25, ;
Width = 169, ;
Name = "Shape5"
Add Object shape6 As Shape With ;
Top = 191, ;
Left = 5, ;
Height = 25, ;
Width = 169, ;
Name = "Shape6"
Add Object shape7 As Shape With ;
Top = 219, ;
Left = 4, ;
Height = 25, ;
Width = 169, ;
Name = "Shape7"
Add Object shape8 As Shape With ;
Top = 248, ;
Left = 5, ;
Height = 25, ;
Width = 169, ;
Name = "Shape8"
Add Object shape9 As Shape With ;
Top = 274, ;
Left = 4, ;
Height = 25, ;
Width = 169, ;
Name = "Shape9"
Add Object shape10 As Shape With ;
Top = 302, ;
Left = 5, ;
Height = 25, ;
Width = 169, ;
Name = "Shape10"
Add Object shape11 As Shape With ;
Top = 327, ;
Left = 4, ;
Height = 25, ;
Width = 169, ;
Name = "Shape11"
Add Object shape12 As Shape With ;
Top = 355, ;
Left = 5, ;
Height = 25, ;
Width = 169, ;
Name = "Shape12"
Add Object shape13 As Shape With ;
Top = 385, ;
Left = 6, ;
Height = 25, ;
Width = 169, ;
Name = "Shape13"
Add Object spinner1 As Spinner With ;
Height = 24, ;
KeyboardHighValue = 3, ;
KeyboardLowValue = 0, ;
Left = 66, ;
SpinnerHighValue = 3.00, ;
SpinnerLowValue = 0.00, ;
Top = 430, ;
Width = 42, ;
Value = 0, ;
Name = "Spinner1"
Add Object label1 As Label With ;
AutoSize = .T., ;
FontBold = .T., ;
FontSize = 10, ;
BackStyle = 0, ;
Caption = "Style(0-3)", ;
Height = 18, ;
Left = 10, ;
Top = 430, ;
Width = 60, ;
ForeColor = Rgb(255,0,0), ;
Name = "Label1"
Procedure spinner1.InteractiveChange
*some images from my blog (internet must be connected )
Local m.lcURL
Do Case
Case This.Value=0
m.lcURL="http://img.over-blog-kiwi.com/1/43/54/07/20170508/ob_c51d41_ylist0.png"
Case This.Value=1
m.lcURL="http://img.over-blog-kiwi.com/1/43/54/07/20170508/ob_7f5213_ylist1.png"
Case This.Value=2
m.lcURL="http://img.over-blog-kiwi.com/1/43/54/07/20170508/ob_1019f1_ylist2.png"
Case This.Value=3
m.lcURL="http://img.over-blog-kiwi.com/1/43/54/07/20170508/ob_258c66_ylist3.png"
Endcase
This.Parent.image1.PictureVal=yloadImg(m.lcURL)
Endproc
Procedure Init
With This.image1
.Left=0
.Top=0
.Stretch=0
.ZOrder(1)
Endwith
This.SetAll("mousepointer",15,"shape")
For i=1 To 13
With Eval("this.shape"+Trans(i))
.BorderStyle=0
.BackStyle=0
.DrawMode=9
.BackColor=255
.Curvature=15
.ZOrder(0)
Endwith
Bindevent(Eval("this.shape"+Trans(i)),"mouseDown",Thisform,"my")
Bindevent(Eval("this.shape"+Trans(i)),"mouseEnter",Thisform,"my1")
Bindevent(Eval("this.shape"+Trans(i)),"mouseLeave",Thisform,"my2")
Endfor
Endproc
Enddefine
*
*-- EndDefine: ycont
*image button class to collapse/expand the menu and move all form controls.
Define Class yec As Image
Picture = ""
Height = 37
Left = 216
MousePointer = 15
Top = 0
Width = 41
ToolTipText = "Expand/collapse"
Name = "Image1"
Procedure Click
With Thisform
Local m.delta
m.delta=.xleft+.xwidth
.ycl=Iif(.ycl=0,1,0)
Do Case
Case .ycl=1
For i=1 To .ControlCount
If Lower( .Controls(i).Name)=="container1"
.Controls(i).Left=-m.delta
Else
.Controls(i).Left=.Controls(i).Left-m.delta
Endi
Endfor
Case .ycl=0
For i=1 To .ControlCount
If Lower( .Controls(i).Name)=="container1"
.Controls(i).Left=.xleft
Else
.Controls(i).Left=.Controls(i).Left+m.delta
Endi
Endfor
Endcase
Endwith
Endproc
Procedure Init
With Thisform
.xleft=.container1.Left
.xwidth=.container1.Width
Endwith
Local m.myvar
TEXT to m.myvar noshow
iVBORw0KGgoAAAANSUhEUgAAACkAAAAlCAIAAABQwFfaAAAAAXNSR0IArs4c6QAAAARnQU1BAACxjwv8YQUAAAAJcEhZcwAADsMAAA7DAcdvqGQAAAB+SURBVFhHY/g/cGDUbvqDwWP3y03lgbQAaYtuQG1ABih2v9xUCFVMbVC46SXUDiQwajcIvNxREwZVTVVARHzTGYzaTX8weOweLdeoDEZouVaOzWo0u+kLRu2mPxg8dtMonYfV7CCYzkfLNWqDASzXRttryGDUbvqDkWn3//8A2CIqyN0zYQIAAAAASUVORK5CYII=
ENDTEXT
This.PictureVal=Strconv(m.myvar,14)
Endproc
Enddefine
*
*-- EndDefine: yec
Function yloadImg
Lparameters lcURL
Local loRequest
m.loRequest = Createobject('MsXml2.XmlHttp')
m.loRequest.Open("GET",lcURL,.F.)
m.loRequest.Send()
Return m.loRequest.ResponseBody
m.loRequest=Null
Endfunc
Click on code to select [then copy] -click outside to deselect
*6* created on 11 of may 2017
*this code builds a vfp editor with some interactive PEM
* a web image is set as background(can customize -can choose a disc image)
*can position the form with parameters left,top on screen (do form yeditor with xleft,xtop)
*rightclick on editbox to fire contextuel menu
*can be a standalone application (exe from a vfp project)
Publi yform
yform=Newobject("yedit")
yform.Show
Read Events
Retu
*
Define Class yedit As Form
BorderStyle = 0
Top = -1
Left = 176
Height = 528
Width = 432
ShowWindow = 2
Caption = "VFP editor"
MaxButton = .F.
AlwaysOnTop = .T.
Name = "Form1"
Add Object image1 As Image With ;
Anchor = 15, ;
Picture = "copy_code.png", ;
Stretch = 2, ;
Height = 529, ;
Left = 0, ;
Top = 0, ;
Width = 433, ;
Name = "Image1"
Add Object edit1 As EditBox With ;
FontSize = 10, ;
Anchor = 15, ;
BorderStyle = 0, ;
Height = 424, ;
Left = 16, ;
Top = 36, ;
Width = 396, ;
Name = "Edit1"
Add Object shape1 As Shape With ;
Top = 486, ;
Left = 80, ;
Height = 36, ;
Width = 142, ;
Anchor = 768, ;
BackStyle = 0, ;
BorderStyle = 0, ;
MousePointer = 15, ;
Name = "Shape1"
Add Object shape2 As Shape With ;
Top = 487, ;
Left = 254, ;
Height = 34, ;
Width = 142, ;
Anchor = 768, ;
BackStyle = 0, ;
BorderStyle = 0, ;
MousePointer = 15, ;
Name = "Shape2"
Add Object optiongroup1 As OptionGroup With ;
AutoSize = .T., ;
ButtonCount = 5, ;
BackStyle = 0, ;
Value = 1, ;
Height = 27, ;
Left = 27, ;
Top = 5, ;
Width = 139, ;
Name = "Optiongroup1", ;
Option1.Caption = "", ;
Option1.Value = 1, ;
Option1.Height = 17, ;
Option1.Left = 5, ;
Option1.Style = 0, ;
Option1.Top = 5, ;
Option1.Width = 18, ;
Option1.AutoSize = .T., ;
Option1.Name = "Option1", ;
Option2.Caption = "", ;
Option2.Height = 17, ;
Option2.Left = 35, ;
Option2.Style = 0, ;
Option2.Top = 5, ;
Option2.Width = 18, ;
Option2.AutoSize = .T., ;
Option2.Name = "Option2", ;
Option3.Caption = "", ;
Option3.Height = 17, ;
Option3.Left = 65, ;
Option3.Style = 0, ;
Option3.Top = 5, ;
Option3.Width = 18, ;
Option3.AutoSize = .T., ;
Option3.Name = "Option3", ;
Option4.Caption = "", ;
Option4.Height = 17, ;
Option4.Left = 89, ;
Option4.Style = 0, ;
Option4.Top = 5, ;
Option4.Width = 18, ;
Option4.AutoSize = .T., ;
Option4.Name = "Option4", ;
Option5.Caption = "", ;
Option5.Height = 17, ;
Option5.Left = 116, ;
Option5.Style = 0, ;
Option5.Top = 5, ;
Option5.Width = 18, ;
Option5.AutoSize = .T., ;
Option5.Name = "Option5"
Add Object spinner1 As Spinner With ;
Height = 24, ;
Left = 227, ;
MousePointer = 15, ;
SpecialEffect = 0, ;
ToolTipText = "Fontsize", ;
Top = 8, ;
Width = 20, ;
Name = "Spinner1"
Add Object spinner2 As Spinner With ;
Height = 24, ;
Left = 345, ;
MousePointer = 15, ;
SpecialEffect = 0, ;
ToolTipText = "Alignment", ;
Top = 8, ;
Width = 20, ;
spinnerLowValue=0,;
spinnerHighValue=2,;
keyboardLowValue=0,;
keyBoardHighValue=2,;
increment=1,;
Name = "Spinner2"
Add Object check1 As Checkbox With ;
Top = 12, ;
Left = 175, ;
Height = 17, ;
Width = 43, ;
AutoSize = .T., ;
Alignment = 0, ;
BackStyle = 0, ;
Caption = "Bold", ;
MousePointer = 15, ;
Name = "Check1"
Add Object check2 As Checkbox With ;
Top = 12, ;
Left = 257, ;
Height = 17, ;
Width = 70, ;
AutoSize = .T., ;
Alignment = 0, ;
BackStyle = 0, ;
Caption = "Readonly", ;
MousePointer = 15, ;
Name = "Check2"
Procedure my1
Lparameters nButton, nShift, nXCoord, nYCoord
*--- aevent create an array laEvents
Aevents( myArray, 0)
*--- reference the calling object
loObject = myArray[1]
Local m.x
m.x=Int(Val(Substr(loObject.Name,6)))
With loObject
*.ToolTipText=.Name
.DrawMode=9
.BackStyle=1
If m.x<=8
.BackColor=Rgb(255,128,0)
Else
.BackColor=255
Endi
.Curvature=15
Endwith
Endproc
Procedure my2
Lparameters nButton, nShift, nXCoord, nYCoord
*--- aevent create an array laEvents
Aevents( myArray, 0)
*--- reference the calling object
loObject = myArray[1]
loObject.BackStyle=0
Endproc
Procedure Init
Lparameters xleft,xtop
If Empty(xleft) And Empty(xtop)
This.AutoCenter=.T.
Else
This.Left=xleft
This.Top=xtop
Endi
this.image1.pictureval=yloadImg("http://img.over-blog-kiwi.com/1/43/54/07/20170511/ob_0506ce_copy-code.png")
With Thisform
For i=1 To .ControlCount
If Lower(.Controls(i).Class)=="shape"
Bindevent(.Controls(i),"mouseEnter",Thisform,"my1")
Bindevent(.Controls(i),"mouseLeave",Thisform,"my2")
Endi
Endfor
.ShowTips=.T.
Endwith
Endproc
Procedure Destroy
Clea Events
Endproc
Procedure edit1.Init
This.Margin=15
TEXT to this.value noshow
Lorem ipsum dolor sit amet, consectetur adipiscing elit. Proin vel risus eget lorem feugiat
fermentum nec a turpis. Phasellus purus sem, mollis ac posuere eget, ornare vel orci. Sed ac rutrum
nulla. Aenean ultrices eget lectus eu efficitur. In hac habitasse platea dictumst. Nulla in iaculis nisi.
Nullam et pulvinar tellus. Donec arcu dui, efficitur a odio non, porta congue dolor. Aenean viverra
auctor sagittis. Integer lobortis dignissim auctor. Proin et volutpat massa.
Cras vitae felis venenatis, egestas sem quis, sodales neque. Donec venenatis hendrerit odio, non
pellentesque metus scelerisque ac. Suspendisse aliquet rhoncus odio id viverra. Vestibulum feugiat
lectus a nisl pulvinar, in tempor metus eleifend. Nunc id odio quam. Praesent egestas lorem ut
sollicitudin consectetur. Vestibulum id bibendum est. Ut vel lacus sapien. Quisque eget molestie
sem. Integer eget purus eu orci molestie aliquam quis in ante. Integer a magna eget lectus finibus
porttitor. Donec fringilla sapien a quam aliquet, pellentesque blandit nisl placerat. Nam hendrerit
velit vel ex aliquam, eget convallis ante mollis.
ENDTEXT
Endproc
Procedure edit1.RightClick
Set Color Of Scheme 1 To R/w*,B+/GR+*,,,,G/GR+
Define Popup raccourci SHORTCUT Relative From Mrow(),Mcol() Color Scheme 1
Define Bar _Med_find Of raccourci Prompt "Rec\<hercher..." ;
KEY CTRL+F, "Ctrl+F" ;
PICTRES _Med_find ;
MESSAGE "Recherche le texte spécifié"
Define Bar _Med_redo Of raccourci Prompt "\<Rétablir" ;
KEY CTRL+R, "Ctrl+R" ;
PICTRES _Med_redo ;
MESSAGE "Rétablit la dernière opération annulée"
Define Bar _Med_undo Of raccourci Prompt "\<Annuler" ;
KEY CTRL+Z, "Ctrl+Z" ;
PICTRES _Med_undo ;
MESSAGE "Annule la dernière modification"
Define Bar _Med_paste Of raccourci Prompt "C\<oller" ;
KEY CTRL+V, "Ctrl+V" ;
PICTRES _Med_paste ;
MESSAGE "Place le contenu du Presse-papiers au point d'insertion"
Define Bar _Med_copy Of raccourci Prompt "Co\<pier" ;
KEY CTRL+c, "Ctrl+C" ;
PICTRES _Med_copy ;
MESSAGE "Copie la sélection et la place dans le Presse-papiers"
Define Bar _Med_cut Of raccourci Prompt "\<Couper" ;
KEY CTRL+x, "Ctrl+X" ;
PICTRES _Med_cut ;
MESSAGE "Enlève la sélection et la place dans le Presse-papiers"
Define Bar _Med_slcta Of raccourci Prompt "Sélec\<tionner tout" ;
KEY CTRL+A, "Ctrl+A" ;
PICTRES _Med_slcta ;
MESSAGE "Sélectionne tout le texte ou tous les éléments de la fenêtre active"
Activate Popup raccourci
Endproc
Procedure shape1.Click
_Cliptext=Thisform.edit1.Value
Messagebox("Text in clipboard!",0+32+4096,'',1100)
Endproc
Procedure shape2.Click
Thisform.Release
Endproc
Procedure optiongroup1.Init
With This
.SetAll("autosize",.T.,"optionbutton")
.SetAll("backstyle",0,"optionbutton")
.SetAll("mousepointer",15,"optionbutton")
.AutoSize=.T.
.SetAll("caption","","optionbutton")
.BackStyle=0
.Option1.ToolTipText="black"
.Option2.ToolTipText="blue"
.Option3.ToolTipText="red"
.Option4.ToolTipText="maroon"
.Option5.ToolTipText="orange"
Endwith
Endproc
Procedure optiongroup1.InteractiveChange
Do Case
Case This.Value=1
Thisform.edit1.ForeColor=0
Case This.Value=2
Thisform.edit1.ForeColor=Rgb(0,0,255)
Case This.Value=3
Thisform.edit1.ForeColor=255
Case This.Value=4
Thisform.edit1.ForeColor=Rgb(128,0,64)
Case This.Value=5
Thisform.edit1.ForeColor=Rgb(255,128,0)
Endcase
Endproc
Procedure spinner1.UpClick
With Thisform.edit1
.FontSize=.FontSize+1
Endwith
Endproc
Procedure spinner1.DownClick
With Thisform.edit1
If .FontSize>8
.FontSize=.FontSize-1
Endi
Endwith
Endproc
Procedure spinner2.InteractiveChange
With Thisform.edit1
.Alignment=This.Value
.Refresh
Endwith
Endproc
Procedure check1.Click
With Thisform.edit1
.FontBold=!.FontBold
Endwith
Endproc
Procedure check2.Click
With Thisform.edit1
.ReadOnly=!.ReadOnly
Endwith
Endproc
Enddefine
*
*-- EndDefine: yedit
function yloadImg
lparameters lcURl
Local loRequest
m.loRequest = Createobject('MsXml2.XmlHttp')
m.loRequest.Open("GET",lcUrl,.F.)
m.loRequest.Send()
return(m.loRequest.ResponseBody )
m.loRequest=Null
endfunc
can make custom image as background to make some cosmetics.
Click on code to select [then copy] -click outside to deselect
*7* created on 31 of may 2017 .....asked by someone on UT.
*Each record of table/cursor is in a button.click on any button to see all record data in a messagebox (can be an editbox...).
*the form is scrollable (as container).the scroolbar appears if needed.
*if the form resized the buttons are re arranged as well.
Clea All
_Screen.WindowState=1
Declare Integer Sleep In kernel32 Integer
Publi oform
oform=Newobject("ybuttons")
oform.Show
Read Events
Retu
*
Define Class ybuttons As Form
Top = 25
Left = 102
Height = 650
Width = 862
ShowWindow = 2
ScrollBars = 2
Caption = "table record in a commandbutton-click any button to see relative info"
BackColor =0 && Rgb(212,208,210)
Name = "form1"
ybackcolor=0
Procedure ybuild
Local m.xspace,m.wbutton,m.delta,m.xleft,m.xtop
m.xtop=20
m.xleft=40
m.wbutton=130
m.delta=4 &&interspace
m.xspace=Int(Thisform.Width-xleft)/(m.wbutton+m.delta) &&buttons by row
Sele ycurs
With Thisform
.LockScreen=.T.
j=0
k=0
Scan
i=Recno()
Try
.AddObject("ycont"+Trans(i),"ycont")
Catch
Endtry
With Eval(".ycont"+Trans(i))
.Width=m.wbutton
.Height=34
Rand(-1)
.shape1.BackColor=Rgb(255*Rand(),255*Rand(),255*Rand())
.shape1.MousePointer=15
.label1.MousePointer=15
.label1.Caption=cust_id
j=j+1
If j<m.xspace
If i=1
k=1
.Left=m.xleft
.Top=m.xtop
Else
.Left=Eval("thisform.ycont"+Trans(i-1)+".left")+Eval("thisform.ycont"+Trans(i-1)+".width")+m.delta
.Top=m.xtop+(k-1)*(.Height+m.delta)
Endi
Else
k=k+1
.Left=m.xleft
.Top=m.xtop+(k-1)*(.Height+m.delta)
j=1
Endi
.Visible=.T.
Try
.Name="ycont"+Trans(i)
Catch
Endtry
Endwith
Bindevent(Eval("thisform.ycont"+Trans(i)+".label1"),"mousedown",Thisform,"my")
Bindevent(Eval("thisform.ycont"+Trans(i)+".shape1"),"mousedown",Thisform,"my")
Bindevent(Eval("thisform.ycont"+Trans(i)),"mouseEnter",Thisform,"my1")
Bindevent(Eval("thisform.ycont"+Trans(i)),"mouseLeave",Thisform,"my2")
Sleep(5) &&to render random backcolor as well
Endscan
.LockScreen=.F.
Endwith
Endproc
Procedure my
Lparameters nButton, nShift, nXCoord, nYCoord
*--- aevent create an array laEvents
Aevents( myArray, 0)
*--- reference the calling object
loObject = myArray[1]
Local N
N=Int(Val(Substr(loObject.Parent.Name,6)))
Local m.myvar
m.myvar=""
Sele ycurs
Go N
m.myvar="Record:"+Trans(N)+Chr(13)
For i=1 To Fcount()
m.myvar=m.myvar+Field(i)+":"+Trans(Eval(Field(i)))+Chr(13)
Endfor
Messagebox(m.myvar,0+32+4096)
Endproc
Procedure Destroy
Clea Events
Endproc
Procedure Load
Close Data All
Sele * From Home(1)+"samples\data\customer" Into Cursor ycurs
*brow
Endproc
Procedure my1
Lparameters nButton, nShift, nXCoord, nYCoord
*--- aevent create an array laEvents
Aevents( myArray, 0)
*--- reference the calling object
loObject = myArray[1]
Thisform.ybackcolor=loObject.shape1.BackColor
loObject.shape1.BackColor=Rgb(240,240,240)
loObject.label1.ForeColor=255
Endproc
Procedure my2
Lparameters nButton, nShift, nXCoord, nYCoord
*--- aevent create an array laEvents
Aevents( myArray, 0)
*--- reference the calling object
loObject = myArray[1]
loObject.shape1.BackColor=Thisform.ybackcolor
loObject.label1.ForeColor=0
Endproc
Procedure Init
Thisform.Resize()
Endproc
Procedure Resize
Thisform.ybuild()
Endproc
Enddefine
*
*-- EndDefine: ybuttons
*this container below can be a simple commandbutton.
Define Class ycont As Container
Top = 24
Left = 24
Width = 157
Height = 49
BackStyle = 0
BorderWidth = 0
Name = "Container1"
Add Object shape1 As Shape With ;
anchor=15,;
Top = 0, ;
Left = 0, ;
Height = 49, ;
Width = 157, ;
Curvature = 15, ;
BorderColor = Rgb(255,0,0), ;
Name = "Shape1"
Add Object label1 As Label With ;
alignment=2,;
Caption = "Label1", ;
Height = 37, ;
Left = 6, ;
Top = 5, ;
Width = 145, ;
Name = "Label1"
Procedure shape1.Init
With This
.Left=0
.Top=0
.Width=.Parent.Width
.Height=.Parent.Height
.ZOrder(1)
.Curvature=15
Endwith
Endproc
Procedure label1.Init
With This
.Width=.Parent.shape1.Width-6
.Left=(.Parent.Width-.Width)/2
.Top=4
.WordWrap=.T.
.FontBold=.T.
.ZOrder(0)
.BackStyle=0
Endwith
Endproc
Enddefine
*
*-- EndDefine: ycont
Click on code to select [then copy] -click outside to deselect
*8*created on 01 of november 2018
*a form titlebar on demand
PUBLIC oform
oform=NEWOBJECT("yform")
oform.Show
read events
RETURN
*
DEFINE CLASS yform AS form
BorderStyle = 0
Height = 308
Width = 925
ShowWindow = 2
AutoCenter = .T.
Caption = "Form Titlebar on demand."
TitleBar = 1
BackColor = RGB(212,210,208)
height0 = .F.
Name = "Form1"
ADD OBJECT shape1 AS shape WITH ;
Top = 12, ;
Left = 588, ;
Height = 289, ;
Width = 325, ;
BorderWidth = 2, ;
BackColor = RGB(255,255,255), ;
Name = "Shape1"
ADD OBJECT grid1 AS grid WITH ;
Height = 205, ;
Left = 24, ;
Top = 71, ;
Width = 540, ;
Name = "Grid1"
ADD OBJECT image1 AS image WITH ;
Stretch = 2, ;
Height = 264, ;
Left = 601, ;
Top = 21, ;
Width = 300, ;
Name = "Image1"
ADD OBJECT label1 AS label WITH ;
AutoSize = .T., ;
FontSize = 11, ;
BackStyle = 0, ;
Caption = "MouseMove at the top of the form to make titlebar visible-MouseLeave to hide it", ;
Height = 19, ;
Left = 36, ;
Top = 38, ;
Width = 509, ;
ForeColor = RGB(128,0,64), ;
Name = "Label1"
PROCEDURE Load
_screen.windowstate=1
ENDPROC
PROCEDURE MouseMove
LPARAMETERS nButton, nShift, nXCoord, nYCoord
if between(nxcoord,0,thisform.width) and between(nycoord,0,20)
thisform.titlebar=1
thisform.height=thisform.height0+(sysmetric(9)+sysmetric(4))
else
thisform.titlebar=0
thisform.height=thisform.height0
endi
ENDPROC
PROCEDURE Init &&internet must be connected for image1.pictureVal
this.titlebar=0
m.lcUrl="http://www.hotel-lagazelledor.com/assets/portail-day-2.jpg"
try
m.loRequest = Createobject('MsXml2.XmlHttp')
m.loRequest.Open("GET",lcUrl,.F.)
m.loRequest.Send()
Thisform.image1.PictureVal=m.loRequest.ResponseBody
m.loRequest=Null
catch
endtry
thisform.height0=thisform.height
ENDPROC
PROCEDURE Destroy
clea events
ENDPROC
PROCEDURE grid1.Init
sele * from home(1)+"samples\data\customer" into cursor ycurs
with this
.recordsource="ycurs"
.recordsourcetype=1
.gridlines=0
.deletemark=.f.
.SetAll("DynamicBackColor","IIF(MOD(RECNO( ), 2)=0, RGB(100,95,155) , RGB(255,255,100))", "Column")
locate
endwith
ENDPROC
ENDDEFINE
*
*-- EndDefine: yform
*Important:All Codes above are tested on VFP9SP2 & windows 10 pro and IE 11 emulation.