Playing with vfp pageframes and subclassing
this is an exercice of pageframe styles. to make the pageframe without its tabs can choose in PEM sheet its properties :themes=.f. and tabs=.f. i present a variety of methods to subclass the pageframe tabs particulary with : -containers tab with a number=the pageframe.pagecount -commandgroup control with a number of buttons=the pageframe.pagecount -optionGroup control with a number of buttons (options)= the pageframe.pagecount using bindevent with a mousedown event replaces the tab pageframe tab action. of course can populate the pages with any vfp controls. the code *2* below downloads some images for tabs (from Bernard Bout pageframe post: http://weblogs.foxite.com/bernardbout/2006/06/07/recreating-onenotetabs-in-vfp9/) In codes 3* and *4* i present method to build images with gradients with vfp9 native gdiplus class...can customize random colors used. To keep certain white areas of your .bmp white, create a mask for it that will override the default.To create a mask for a .bmp: -Open the .bmp file in Paint or another bitmap utility. -Blacken all areas of the picture that you want to be displayed exactly as they are in the .bmp file. Leave the areas you want to be transparent as white. -Save the file in the same directory and with the same name as the .bmp file but with an .msk extension. can also use transparent gif or png for this purpose. [post 229]
Click on code to select [then copy] -click outside to deselect
*1* created on thursday 27 of april 2017
*!* the code creates a pageframe with subclassed tabs by containers (image+label).
*!* the tab class is coded in the ycont class below
*!*the tabs are created by the pageframe.pagecount property(number of tabs)
*!* the image is encoded to hexBinay64 and retrieved as blob in pictureVal image control property.
*!* the pageframe play a diaporama with 8 web images:internet must be connected
*!* the timer1 is (_screen.ydiapo=.t.): this makes a cycling diaporama of web pictures (can disable it:timer1.enabled=.f.)
*!* the pages can embed any vfp control.
*!* bindevent is coded in my procedure.it locates the tab concerned by click and do the consequent job.
Create Cursor yhm (ximage 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
_screen.windowstate=1
_screen.addproperty("ydiapo",.t.) &&.f. for no automatic diaporama
Publi yform
yform=Newobject("ypgf")
yform.Show
Read Events
Retu
*
Define Class ypgf As Form
Height = 600
Width = 890
ShowWindow = 2
AutoCenter = .T.
Caption = "Form1"
Name = "Form1"
jj=0 &&custom counter
Add Object pageframe1 As PageFrame With ;
ErasePage = .T., ;
PageCount = 10, ;
Top = 61, ;
Left = 12, ;
Width = 216, ;
Height = 503, ;
Name = "Pageframe1"
Add Object ycnt As Container With ;
Top = 20, ;
Left = 12, ;
Width = 840, ;
Height = 49, ;
Name = "yCNT"
Add Object timer1 As timer With ;
enabled=.f.,;
interval=3000,;
name="timer1"
procedure timer1.timer
thisform.jj=thisform.jj+1
if thisform.jj>thisform.pageframe1.pagecount
thisform.jj=1
endi
x=eval("thisform.ycnt.container"+trans(thisform.jj)+".label1")
x.mousedown(1)
endproc
Procedure ycnt.Init
Local m.delta
m.delta=5
With This
Local ncount
ncount=This.Parent.pageframe1.PageCount
.BackColor=0
Local x
For j=1 To ncount
.AddObject("container"+Trans(j),"zcont")
x=Eval(".container"+Trans(j))
x.Width=0.90*Floor(.Parent.Width/ncount)
x.label1.Left=(x.Width-x.label1.Width)/2
If j=1
x.Left=4
Else
Y=Eval(".container"+Trans(j-1))
x.Left=Y.Left+Y.Width+m.delta
Endi
x.Top=1
x.Visible=.T.
Endfor
.Refresh
Endwith
With Thisform.pageframe1
.Left=This.Left
.Top=This.Top+This.Height-2
.Width=This.Width
.Themes=.F.
.Tabs=.F.
.ZOrder(1)
For i=1 To .PageCount
.Pages(i).BackColor=Rgb(255*Rand(),255*Rand(),255*Rand())
.Pages(i).AddObject("image1","image")
With .Pages(i).image1
.Anchor=0
.Left=10
.Top=10
.Width=.Parent.Parent.Width-20
.Height=.Parent.Parent.Height-20
.Stretch=2
.Visible=.T.
.Name="image1"
.Picture=""
Endwith
Endfor
.Refresh
Endwith
Endproc
procedure init
sele yhm
thisform.ycnt.container1.label1.mousedown(1)
thisform.timer1.enabled=_screen.ydiapo &&.f. for no diaporama
endproc
Procedure my
Lparameters nButton, nShift, nXCoord, nYCoord
*--- aevent create an array laEvents
Aevents( myArray, 0)
*--- reference the calling object
loObject = myArray[1]
DoDefault()
local i
i=Int(Val(Substr(loObject.Parent.Name,10))) &&containerX
loObject.Parent.Parent.SetAll("visible",.F.,"image")
loObject.Parent.Parent.SetAll("forecolor",Rgb(255,255,255),"label")
loObject.ForeColor=255
loObject.Parent.image1.Visible=.T.
Thisform.pageframe1.ActivePage=i
With Thisform.pageframe1.Pages(i).image1
.Left=10
.Top=10
.Width=.Parent.Parent.Width-20
.Height=.Parent.Parent.Height-20
Sele yhm
try
skip
catch
locate
endtry
if empty(ximage)
locate
endi
.PictureVal=yloadImg(ximage)
Endwith
Endproc
Procedure Destroy
Clea Events
Endproc
Enddefine
*
*-- EndDefine: ypgf
*
Define Class zcont As Container
Top = 10
Left = 0
Width = 180
Height = 48
BackColor = Rgb(0,0,0)
Name = "Container1"
Add Object image1 As Image With ;
Picture = "", ;
Stretch = 2, ;
BackStyle = 0, ;
Height = 38, ;
Left = -1, ;
Top = 6, ;
Width = 59, ;
Name = "Image1"
Add Object label1 As Label With ;
AutoSize = .T., ;
FontBold = .T., ;
BackStyle = 0, ;
Caption = "Page1", ;
Height = 17, ;
Left = 8, ;
Top = 14, ;
Width = 38, ;
ForeColor = Rgb(255,255,255), ;
Name = "Label1"
Procedure Init
local m.myvar
text to m.myvar noshow
R0lGODlhOwAmAHCSACH/C05FVFNDQVBFMi4wAwEAAAAh+QQFCgCSACwAAAAAOwAmAIcAAAAAADMAAGYAAJkAAMwAAP8AKwAAKzMAK2YAK5kAK8wAK/8AVQAAVTMAVWYAVZkAVcwAVf8AgAAAgDMAgGYAgJkAgMwAgP8AqgAAqjMAqmYAqpkAqswAqv8A1QAA1TMA1WYA1ZkA1cwA1f8A/wAA/zMA/2YA/5kA/8wA//8zAAAzADMzAGYzAJkzAMwzAP8zKwAzKzMzK2YzK5kzK8wzK/8zVQAzVTMzVWYzVZkzVcwzVf8zgAAzgDMzgGYzgJkzgMwzgP8zqgAzqjMzqmYzqpkzqswzqv8z1QAz1TMz1WYz1Zkz1cwz1f8z/wAz/zMz/2Yz/5kz/8wz//9mAABmADNmAGZmAJlmAMxmAP9mKwBmKzNmK2ZmK5lmK8xmK/9mVQBmVTNmVWZmVZlmVcxmVf9mgABmgDNmgGZmgJlmgMxmgP9mqgBmqjNmqmZmqplmqsxmqv9m1QBm1TNm1WZm1Zlm1cxm1f9m/wBm/zNm/2Zm/5lm/8xm//+ZAACZADOZAGaZAJmZAMyZAP+ZKwCZKzOZK2aZK5mZK8yZK/+ZVQCZVTOZVWaZVZmZVcyZVf+ZgACZgDOZgGaZgJmZgMyZgP+ZqgCZqjOZqmaZqpmZqsyZqv+Z1QCZ1TOZ1WaZ1ZmZ1cyZ1f+Z/wCZ/zOZ/2aZ/5mZ/8yZ///MAADMADPMAGbMAJnMAMzMAP/MKwDMKzPMK2bMK5nMK8zMK//MVQDMVTPMVWbMVZnMVczMVf/MgADMgDPMgGbMgJnMgMzMgP/MqgDMqjPMqmbMqpnMqszMqv/M1QDM1TPM1WbM1ZnM1czM1f/M/wDM/zPM/2bM/5nM/8zM////AAD/ADP/AGb/AJn/AMz/AP//KwD/KzP/K2b/K5n/K8z/K///VQD/VTP/VWb/VZn/Vcz/Vf//gAD/gDP/gGb/gJn/gMz/gP//qgD/qjP/qmb/qpn/qsz/qv//1QD/1TP/1Wb/1Zn/1cz/1f///wD//zP//2b//5n//8z///8AAAAAAAAAAAAAAAAI/wDtCRxIsKDBgwgTKiwIz17Dhw4jQpwosSLFixYzNhS4MSLHgR1Dghz5saTHkyIJblzpkSXLii1jwnRZEiLJjjJrqjSZM+fLlDRj/pRpM6hRnUSRJvWJ9OXSpUOhfowaVarVqk6vNmV4c6tUoF5/Fg1LVqvVrmWppg079ilOrErdHoQrFK3ToDpdtlVr1ibKnidN8h0sWCtNwn2nov0b2KvZwoqTIgb7NbLfqj2HYk4Z+G3lukz/arbM+GhjwpQdp07MeKva13FL51W6dzHno3wlk/xsGvJj0ap5op4N2q/c4lxl2wa+lmht5DBJjz4L+a7wzjurVwfAvbv37+C5Ty1vGL68+fPouYeGl769e/Nb38ufr14m/fvu7ePfj74k///nbQTggOXZQ2B3AQEAOw==
endtext
With This
local i
i=Substr(This.Name,10)
With .label1
.FontBold=.T.
.fontname="Tahoma"
.fontsize=8
.Alignment=0
.BackStyle=0
.AutoSize=.T.
.Left=4
.MousePointer=15
.Caption="Page"+i
.ForeColor=Rgb(255,255,255)
.ZOrder(0)
Endwith
.Width=.label1.Width+10
.BackStyle=0
.Width=0.90*Floor(Thisform.ycnt.Width/Thisform.pageframe1.PageCount) &&already set as real value
With .image1
.pictureVal=strconv(m.myvar,14)
.Left=0
.Top=0
.Width=.Parent.Width
.Height=.Parent.Height
.Visible=.F.
.ZOrder(1)
Endwith
.Refresh
Endwith
Bindevent(This.label1,"mousedown",Thisform,"my")
Endproc
Procedure image1.Init
This.ZOrder(1)
Endproc
Enddefine
*
*-- EndDefine: zcont
*internet must be connected
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
the image tab is a transparent gif encoded with _cliptext=strconv(filetostr(getpict('gif'),13) and restitued as pictureval with strconv(string,14)
Click on code to select [then copy] -click outside to deselect
*2*
*this code subclasses the tabs of a native pageframe with 2 methods
*1-a container with image+label+icon in each tab (make sure imlages are downloaded for this purpose).
*2-an optionGroup control
*3-a commandGroup control
Local m.ydownl
m.ydownl=.T. &&use it once to download images and change to .f.
Set Defa To Addbs(Justpath(Sys(16,1)))
If m.ydownl=.t.
*******begin downloads************
*images are from Bernard Bout foxite blog (pageframe post)
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/1/43/54/07/20170427/ob_ccbd36_aquagrad.bmp"
lcDownloadLoc="aquagrad.bmp"
Case i=2
lcUrl="http://img.over-blog-kiwi.com/1/43/54/07/20170427/ob_99b305_aquagrad1.jpg"
lcDownloadLoc="aquagrad1.jpg"
Case i=3
lcUrl="http://img.over-blog-kiwi.com/1/43/54/07/20170427/ob_45b772_aquatab.bmp"
lcDownloadLoc="aquatab.bmp"
Case i=4
lcUrl="http://img.over-blog-kiwi.com/1/43/54/07/20170427/ob_55cc94_bluegrad.bmp"
lcDownloadLoc="bluegrad.bmp"
Case i=5
lcUrl="http://img.over-blog-kiwi.com/1/43/54/07/20170427/ob_55cc94_bluegrad.bmp"
lcDownloadLoc="fonds.jpg"
Case i=6
lcUrl="http://img.over-blog-kiwi.com/1/43/54/07/20170427/ob_e49447_bluetab.bmp"
lcDownloadLoc="blueTab.bmp"
Case i=7
lcUrl="http://img.over-blog-kiwi.com/1/43/54/07/20170427/ob_14a179_greengrad.bmp"
lcDownloadLoc="greenGrad.bmp"
Case i=8
lcUrl="http://img.over-blog-kiwi.com/1/43/54/07/20170427/ob_2ce8d0_greentab.bmp"
lcDownloadLoc="greenTab.bmp"
Case i=9
lcUrl="http://img.over-blog-kiwi.com/1/43/54/07/20170427/ob_c8faa6_majentagrad.bmp"
lcDownloadLoc="majentaGrad.bmp"
Case i=10
lcUrl="http://img.over-blog-kiwi.com/1/43/54/07/20170427/ob_6b0a10_majentatab.bmp"
lcDownloadLoc="majentaTab.bmp"
Case i=11
lcUrl="http://img.over-blog-kiwi.com/1/43/54/07/20170427/ob_6e6515_orangegrad.bmp"
lcDownloadLoc="orangeGrad.bmp"
Case i=12
lcUrl="http://img.over-blog-kiwi.com/1/43/54/07/20170427/ob_83c7e3_orangetab.bmp"
lcDownloadLoc="orangeTab.bmp"
Case i=13
lcUrl="http://img.over-blog-kiwi.com/1/43/54/07/20170427/ob_3c2589_purplegrad.bmp"
lcDownloadLoc="purpleGrad.bmp"
Case i=14
lcUrl="http://img.over-blog-kiwi.com/1/43/54/07/20170427/ob_224d84_purpletab.bmp"
lcDownloadLoc="purpleTab.bmp"
Case i=15
lcUrl="http://img.over-blog-kiwi.com/1/43/54/07/20170427/ob_edc782_tealgrad.bmp"
lcDownloadLoc="tealgradbmp"
Case i=16
lcUrl="http://img.over-blog-kiwi.com/1/43/54/07/20170427/ob_f2621a_tealtab.bmp"
lcDownloadLoc="tealTab.bmp"
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
Publi yform
yform=Newobject("ypgf")
yform.Show
Read Events
Retu
*
Define Class ypgf As Form
Height = 600
Width = 750
ShowWindow = 2
BackColor=0
AutoCenter = .T.
Caption = "3 external methods to command and stylize a pageframe."
Name = "Form1"
Add Object pageframe1 As PageFrame With ;
PageCount = 5, ;
Top = 60, ;
Left = 48, ;
Width = 624, ;
Height = 500, ;
Tabs = .F., ;
Themes = .F., ;
Name = "Pageframe1", ;
Page1.Caption = "Page1", ;
Page1.Picture = "aquagrad.bmp", ;
Page1.Name = "Page1", ;
Page2.Caption = "Page2", ;
Page2.Picture = "majentagrad.bmp", ;
Page2.Name = "Page2", ;
Page3.Caption = "Page3", ;
Page3.Name = "Page3", ;
Page4.Caption = "Page4", ;
Page4.Name = "Page4", ;
Page5.Caption = "Page5", ;
Page5.Name = "Page5"
Add Object optiongroup1 As OptionGroup With ;
ButtonCount = 1, ;
Value = 0, ;
Height = 26, ;
Left = 159, ;
Top = 57, ;
Width = 322, ;
BackColor = Rgb(128,255,0), ;
Name = "Optiongroup1", ;
Option1.Caption = "Option1", ;
Option1.Height = 17, ;
Option1.Left = 5, ;
Option1.Top = 5, ;
Option1.Width = 61, ;
Option1.Name = "Option1"
Add Object commandgroup1 As CommandGroup With ;
AutoSize = .F., ;
ButtonCount = 1, ;
Value = 0, ;
Height = 48, ;
Left = 84, ;
SpecialEffect = 0, ;
Top = 8, ;
Width = 444, ;
BackColor = Rgb(255,215,196), ;
Name = "Commandgroup1", ;
Command1.Top = 5, ;
Command1.Left = 5, ;
Command1.Height = 27, ;
Command1.Width = 84, ;
Command1.Caption = "Command1", ;
Command1.Name = "Command1"
Add Object ycont As Container With ;
Top = 24, ;
Left = 84, ;
Width = 537, ;
Height = 37, ;
BackStyle = 0, ;
BorderWidth = 0, ;
Name = "ycont"
Add Object optiongroup2 As OptionGroup With ;
AutoSize = .F., ;
ButtonCount = 4, ;
Value = 1, ;
Height = 36, ;
Left = 180, ;
Top = 568, ;
Width = 300, ;
Name = "Optiongroup2", ;
Option1.Caption = "Style1", ;
Option1.Value = 1, ;
Option1.Height = 17, ;
Option1.Left = 5, ;
Option1.Style = 0, ;
Option1.Top = 5, ;
Option1.Width = 67, ;
Option1.AutoSize = .T., ;
Option1.Name = "Option1", ;
Option2.Caption = "Style2", ;
Option2.Height = 17, ;
Option2.Left = 82, ;
Option2.Style = 0, ;
Option2.Top = 5, ;
Option2.Width = 67, ;
Option2.AutoSize = .T., ;
Option2.Name = "Option2", ;
Option3.Caption = "Style3", ;
Option3.Height = 17, ;
Option3.Left = 156, ;
Option3.Style = 0, ;
Option3.Top = 5, ;
Option3.Width = 67, ;
Option3.AutoSize = .T., ;
Option3.Name = "Option3", ;
Option4.Caption = "Native", ;
Option4.Height = 17, ;
Option4.Left = 230, ;
Option4.Top = 6, ;
Option4.Width = 61, ;
Option4.Name = "Option4"
Procedure pageframe1.Init
With This.Page1
.AddObject("image1","image")
With .image1
.Picture = Home(1)+"graphics\metafiles\business\apptbook.wmf"
.Stretch = 2
.Height = .Parent.Parent.Height-20
.Left = 10
.Top = 10
.Width = .Parent.Parent.Width-20
.RotateFlip = 1
.Name = "Image1"
.Visible=.T.
Endwith
.AddObject("edit1","editbox")
With .edit1
.Height = 203
.Left = 322
.Top = 82
.Width = 186
.Name = "Edit1"
.Visible=.T.
Endwith
With .edit1
.FontSize=8
TEXT to .value pretext 7 noshow
Lorem ipsum dolor sit amet, consectetur adipiscing elit. Proin vel risus eget lorem feugiat
fermentum nec a turpis. Phasellus purus sem, mollis ac posuere eget, ornare vel orci. Sed ac rutrum
nulla. Aenean ultrices eget lectus eu efficitur. In hac habitasse platea dictumst. Nulla in iaculis nisi.
Nullam et pulvinar tellus. Donec arcu dui, efficitur a odio non, porta congue dolor. Aenean viverra
auctor sagittis. Integer lobortis dignissim auctor. Proin et volutpat massa.
ENDTEXT
Endwith
Endwith
With This.Page2
.AddObject("image1","image")
With .image1
.Picture = Home(1)+"graphics\metafiles\business\laptop2.wmf"
.Stretch = 2
.Height = 190
.Left = 34
.Top = 22
.Width = 298
.Name = "Image1"
.Visible=.T.
Endwith
Endwith
With This.Page3
.AddObject("edit1","editbox")
With .edit1
.Height =200
.Left = 99
.Top = 69
.Width = 379
.Name = "Edit1"
.Visible=.T.
Try
.Value=.Parent.Parent.Pages(1).edit1.Value
Catch
Endtry
Endwith
Endwith
With This.Page4
.AddObject("label1" ,"label")
With .label1
.AutoSize = .T.
.FontBold = .T.
.BackStyle=0
.FontName = "Segoe Script"
.FontSize = 42
.Caption = "Hello World"
.Height = 96
.Left = 91
.Top = 45
.Width = 364
.Name = "Label1"
.Visible=.T.
Endwith
.AddObject("list1","listbox")
With .list1
.Height = 133
.Left = 72
.Top = 156
.Width = 289
.Name = "List1"
.Visible=.T.
Endwith
.AddObject("label2","label")
With .label2
.AutoSize = .T.
.FontBold = .T.
.FontName = "Segoe Script"
.FontSize = 42
.BackStyle = 0
.Caption = "Hello World"
.Height = 96
.Left = 85
.Top = 48
.Width = 364
.ForeColor = Rgb(0,255,0)
.Name = "Label2"
.Visible=.T.
Endwith
Endwith
With This.Page5
.AddObject("image1","image")
With .image1
.Picture = Home(1)+"graphics\metafiles\business\answmach.wmf"
.Stretch = 2
.Height = 85
.Left = 38
.Top = 68
.Width = 121
.Name = "Image1"
.Visible=.T.
Endwith
.AddObject("image2","image")
With .image2
.Picture =Home(1)+ "graphics\metafiles\business\digitnum.wmf"
.Stretch = 2
.Height = 126
.Left = 252
.Top = 126
.Width = 198
.Name = "Image2"
.Visible=.T.
Endwith
Endwith
Endproc
Procedure my
Lparameters nButton, nShift, nXCoord, nYCoord
*--- aevent create an array laEvents
Aevents( myArray, 0)
*--- reference the calling object
loObject = myArray[1]
*messagebox(loObject.name)
N= Int(Val(Substr(loObject.Name,7)))
With Thisform.pageframe1
.ActivePage=N
.Refresh
Endwith
Endproc
Procedure my1
Lparameters nButton, nShift, nXCoord, nYCoord
*--- aevent create an array laEvents
Aevents( myArray, 0)
*--- reference the calling object
loObject = myArray[1]
*messagebox(loObject.name)
N= Int(Val(Substr(loObject.Name,8)))
With Thisform.pageframe1
.ActivePage=N
.Refresh
Endwith
Endproc
Procedure my2
Lparameters nButton, nShift, nXCoord, nYCoord
*--- aevent create an array laEvents
Aevents( myArray, 0)
*--- reference the calling object
loObject = myArray[1]
*messagebox(loObject.parent.name)
Local N,x
m.n= Int(Val(Substr(loObject.Parent.Name,10)))
m.x=loObject.Parent
m.x.ZOrder(0)
With Thisform.pageframe1
.ActivePage=N
.Refresh
Endwith
Endproc
Procedure Init
With Thisform.pageframe1
.Width=.PageCount*(Thisform.ycont.container1.Width+10)
.Top=Thisform.ycont.Top+Thisform.ycont.Height-4
Endwith
With Thisform.optiongroup1
.Left=Thisform.pageframe1.Left+2
.Width=Thisform.pageframe1.Width
.SetAll("picture",Home(1)+"gtaphics\icons\misc\misc015.ico","commandbutton")
.SetAll("picturePosition",1,"commandbutton")
Endwith
Endproc
Procedure Destroy
Clea Events
Endproc
Procedure optiongroup1.Init
With This
.ButtonCount=Thisform.pageframe1.PageCount
.Refresh
For i=1 To .ButtonCount
With .Buttons(i)
If i=1
.Left=0
Else
.Left=Eval("thisform.optionGroup1.option"+Trans(i-1)+".left")+ Eval("thisform.optionGroup1.option"+Trans(i-1)+".width+5")
Endi
.Top=1
.Width=Int(Thisform.pageframe1.Width/Thisform.pageframe1.PageCount)
.Height=27
.SpecialEffect=2
.MousePointer=15
.BackStyle=0
.Caption="Page"+Trans(i)
Endwith
Bindevent(.Buttons(i),"mousedown",Thisform,"my")
Endfor
Endwith
Endproc
Procedure commandgroup1.Init
Local gnbre
gnbre=Adir(gabase,Home(1)+"graphics\icons\win95\*.ico")
With This
.ButtonCount=Thisform.pageframe1.PageCount
.Refresh
For i=1 To .ButtonCount
With .Buttons(i)
If i=1
.Left=0
Else
.Left=Eval("thisform.commandGroup1.command"+Trans(i-1)+".left")+ Eval("thisform.commandGroup1.command"+Trans(i-1)+".width+5")
Endi
.Top=7
.Width=Int(Thisform.pageframe1.Width/Thisform.pageframe1.PageCount)-10
.Height=34
.SpecialEffect=2
.MousePointer=15
.BackColor=Rgb(0,255,0)
.Caption="Page"+Trans(i)
Local ra
ra=Int((gnbre)*Rand()+1)
.Picture=Home(1)+"graphics\icons\win95\"+gabase(ra,1)
.PicturePosition=1
Endwith
Bindevent(.Buttons(i),"mousedown",Thisform,"my1")
Endfor
.Width=.ButtonCount*(.Buttons(1).Width) +20
Endwith
Endproc
Procedure ycont.Init
Local m.ysep
m.ysep=12
With This
For i=1 To Thisform.pageframe1.PageCount
.AddObject("container"+Trans(i),"ycnt")
With Eval(".container"+Trans(i))
If i=1
.Left=5
Else
.Left=Eval("thisform.ycont.container"+Trans(i-1)+".left")+Eval("thisform.ycont.container"+Trans(i-1)+".width")-m.ysep
Endi
.Top=Thisform.ycont.container1.Top
Do Case
Case i=1
.image1.Picture="aquatab.bmp"
.image2.Picture=Home(1)+"graphics\icons\misc\face05.ico"
.label1.Caption="Page1"
Thisform.pageframe1.Pages(1).Picture="aquaGrad.bmp"
Case i=2
.image1.Picture="bluetab.bmp"
.image2.Picture=Home(1)+"graphics\icons\misc\misc05.ico"
.label1.Caption="Page2"
Thisform.pageframe1.Pages(2).Picture="blueGrad.bmp"
Case i=3
.image1.Picture="greentab.bmp"
.image2.Picture=Home(1)+"graphics\icons\misc\misc15.ico"
.label1.Caption="Page3"
Thisform.pageframe1.Pages(3).Picture="greenGrad.bmp"
Case i=4
.image1.Picture="Majentatab.bmp"
.image2.Picture=Home(1)+"graphics\icons\misc\clock02.ico"
.label1.Caption="Page4"
Thisform.pageframe1.Pages(4).Picture="MajentaGrad.bmp"
Case i=5
.image1.Picture="orangetab.bmp"
.image2.Picture=Home(1)+"graphics\icons\win95\audio.ico"
.label1.Caption="Page5"
Thisform.pageframe1.Pages(5).Picture="orangeGrad.bmp"
Case i=6
.image1.Picture="orangetab.bmp"
.image2.Picture=Home(1)+"graphics\icons\win95\audio.ico"
.label1.Caption="Page6"
Thisform.pageframe1.Pages(6).Picture="orangeGrad.bmp"
Endcase
.Visible=.T.
Endwith
Endfor
.Left=Thisform.pageframe1.Left+2
.Width=Thisform.pageframe1.PageCount*(Thisform.ycont.container1.Width-12)+20
Endwith
Endproc
Procedure optiongroup2.InteractiveChange
Do Case
Case This.Value=1
With Thisform
.ycont.Visible=.T.
.commandgroup1.Visible=.F.
.optiongroup1.Visible=.F.
.pageframe1.Tabs=.F.
Endwith
Case This.Value=2
With Thisform
.ycont.Visible=.F.
.commandgroup1.Visible=.F.
.optiongroup1.Visible=.T.
.optiongroup1.Top=Thisform.pageframe1.Top-.optiongroup1.Height+4
.optiongroup1.Left=Thisform.ycont.Left
.pageframe1.Tabs=.F.
Endwith
Case This.Value=3
With Thisform
.ycont.Visible=.F.
.commandgroup1.Visible=.T.
.optiongroup1.Visible=.F.
.pageframe1.Tabs=.F.
.commandgroup1.Top=Thisform.ycont.Top-14
.commandgroup1.Left=Thisform.ycont.Left
Endwith
Case This.Value=4
With Thisform
.ycont.Visible=.F.
.commandgroup1.Visible=.F.
.optiongroup1.Visible=.F.
.pageframe1.Tabs=.T.
.pageframe1.SetAll("forecolor",Rgb(255,255,255),"page")
.pageframe1.SetAll("backcolor",0,"page")
.pageframe1.SetAll("fontbold",.T.,"page")
.Refresh
Endwith
Endcase
Endproc
Procedure optiongroup2.Init
This.InteractiveChange()
Endproc
Enddefine
*
*-- EndDefine: ypgf
* tabs container class for option 1
Define Class ycnt As Container
Top = 12
Left = -3
Width = 120
Height = 27
Picture = Home(1)+"graphics\icons\misc\misc05.ico"
BackStyle = 0
BorderWidth = 0
MousePointer = 15
Name = "Container1"
Add Object image1 As Image With ;
Picture = "aquatab.bmp", ;
Height = 20, ;
Left = 4, ;
Top = 3, ;
Width = 112, ;
backstyle=0, ;
Name = "Image1"
Add Object Command1 As CommandButton With ;
Top = -2, ;
Left = 84, ;
Height = 25, ;
Width = 37, ;
Caption = "", ;
Style = 1, ;
Name = "Command1"
Add Object label1 As Label With ;
FontSize = 8, ;
BackStyle = 0, ;
Caption = "Caption1", ;
Height = 25, ;
Left = 42, ;
Top = 6, ;
Width = 61, ;
Name = "Label1"
Add Object image2 As Image With ;
Picture =Home(1)+ "graphics\icons\misc\face05.ico", ;
Stretch = 2, ;
BackStyle = 0, ;
Height = 16, ;
Left = 22, ;
Top = 5, ;
Width = 16, ;
Name = "Image2"
Procedure Init
With This.Command1
.Left=-10
.Top=-10
.Width=.Parent.Width+20
.Height=.Parent.Height+20
.ZOrder(0)
.MousePointer=15
Endwith
Bindevent(This.Command1,"mousedown",Thisform,"my2")
Endproc
Enddefine
*
*-- EndDefine: asup
Click on code to select [then copy] -click outside to deselect
*3* created on friday 28 of april 2017
*create 2 bmp images horizontal and vertical with linear gradient 2 color randomly for each pageframe tab
*uses vfp9 native class gdiplus
*set the n to the pageframe.pagecount to create the consequent number of images in the subFolder gimages.
Clea All
Clea Resources
Set Safe Off
Local m.yrep
m.yrep=Addbs(Justpath(Sys(16,1)))
Set Defa To (yrep)
If !Directory (m.yrep+"gimages")
Md m.yrep+"Gimages")
Endi
Local nWidth,lnHeight As Integer
Set Classlib To Locfile (Home(1)+"ffc\_gdiplus.vcx")
Local N
N=7 &&5 images H and 5 images V
For j=1 To N
Local OBitmap, oGraphics, Open, NY,NX, cFileName1,cFilename2
*hoprizontal
lnWidth= 130
lnHeight= 30
m.cFileName1 =m.yrep+"Gimages\H"+Trans(j)+".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=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.cFileName1, "image/bmp")
*!* *format saved with vfp9 gdiplus class can be for ex.
*!* image/jpeg", "quality=80"
*!* image/bmp
*!* image/png
*!* image/gif....
m.oPen=Null
m.oGraphics=Null
m.OBitmap=Null
Inke(1)
*vertical
lnWidth= 2
lnHeight= 600
m.cFilename2 =m.yrep+"Gimages\V"+Trans(j)+".bmp"
m.OBitmap = Createobject ("gpBitmap")
m.OBitmap. Create (lnWidth, lnHeight)
m.oGraphics = Createobject ("gpGraphics")
m.oGraphics.CreateFromImage (m.OBitmap)
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.cFilename2, "image/bmp")
m.oPen=Null
m.oGraphics=Null
m.OBitmap=Null
Endfor
Set Classlib To
Local m.OO
m.OO=m.yrep+"Gimages"
Run/N explorer &OO
Function 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
Click on code to select [then copy] -click outside to deselect
*4* created on friday 28 of april 2017
*this code tests the gradients images created by previous code *3* on a pageframe with subclassed tabs.
Set Defa To Addbs(Justpath(Sys(16,1)))
Publi yform
yform=Newobject("ypgf")
yform.Show
Read Events
Retu
*
Define Class ypgf As Form
Height = 512
Width = 702
ShowWindow = 2
AutoCenter = .T.
Caption = "stylisze a pageframe."
Name = "Form1"
Add Object pageframe1 As PageFrame With ;
ErasePage = .T., ;
PageCount = 6, ;
Top = 60, ;
Left = 48, ;
Width = 624, ;
Height = 382, ;
Tabs = .F., ;
Themes = .F., ;
Name = "Pageframe1"
Add Object ycont As Container With ;
Top = 12, ;
Left = 48, ;
Width = 624, ;
Height = 49, ;
BackStyle = 0, ;
BorderWidth = 0, ;
Name = "ycont"
Procedure my
Lparameters nButton, nShift, nXCoord, nYCoord
*--- aevent create an array laEvents
Aevents( myArray, 0)
*--- reference the calling object
loObject = myArray[1]
*messagebox(loObject.name)
N= Int(Val(Substr(loObject.Name,7)))
With Thisform.pageframe1
.ActivePage=N
.Refresh
Endwith
Endproc
Procedure my1
Lparameters nButton, nShift, nXCoord, nYCoord
*--- aevent create an array laEvents
Aevents( myArray, 0)
*--- reference the calling object
loObject = myArray[1]
*messagebox(loObject.name)
N= Int(Val(Substr(loObject.Name,8)))
With Thisform.pageframe1
.ActivePage=N
.Refresh
Endwith
Endproc
Procedure my2
Lparameters nButton, nShift, nXCoord, nYCoord
*--- aevent create an array laEvents
Aevents( myArray, 0)
*--- reference the calling object
loObject = myArray[1]
Local N,x
m.n= Int(Val(Substr(loObject.Parent.Name,10)))
m.x=loObject.Parent
m.x.ZOrder(0)
With Thisform.pageframe1
.ActivePage=N
.Refresh
Endwith
Endproc
Procedure Destroy
Clea Events
Endproc
Procedure ycont.Init
With This
For i=1 To Thisform.pageframe1.PageCount
.AddObject("container"+Trans(i),"asup")
With Eval(".container"+Trans(i))
If i=1
.Left=5
Else
.Left=Eval("thisform.ycont.container"+Trans(i-1)+".left")+Eval("thisform.ycont.container"+Trans(i-1)+".width")-12
Endi
.Top=10
Do Case
Case i=1
.image1.Picture="h1.bmp"
.image2.Picture=Home(1)+"graphics\icons\misc\face05.ico"
.label1.Caption="Caption1"
Thisform.pageframe1.Pages(1).Picture="v1.bmp"
Case i=2
.image1.Picture="h2.bmp"
.image2.Picture=Home(1)+"graphics\icons\misc\misc05.ico"
.label1.Caption="Caption2"
Thisform.pageframe1.Pages(2).Picture="v2.bmp"
Case i=3
.image1.Picture="h3.bmp"
.image2.Picture=Home(1)+"graphics\icons\misc\misc15.ico"
.label1.Caption="Caption3"
Thisform.pageframe1.Pages(3).Picture="v3.bmp"
Case i=4
.image1.Picture="h4.bmp"
.image2.Picture=Home(1)+"graphics\icons\misc\clock02.ico"
.label1.Caption="Caption4"
Thisform.pageframe1.Pages(4).Picture="v4.bmp"
Case i=5
.image1.Picture="h5.bmp"
.image2.Picture=Home(1)+"graphics\icons\win95\audio.ico"
.label1.Caption="Caption5"
Thisform.pageframe1.Pages(5).Picture="v5.bmp"
Case i=6
.image1.Picture="h6.bmp"
.image2.Picture=Home(1)+"graphics\icons\win95\audio.ico"
.label1.Caption="Caption6"
Thisform.pageframe1.Pages(6).Picture="v6.bmp"
Endcase
.Visible=.T.
Endwith
Endfor
.Left=Thisform.pageframe1.Left+2
.Width=Thisform.pageframe1.PageCount*(Thisform.ycont.container1.Width-12)+20
Endwith
Endproc
Procedure Init
With Thisform.pageframe1
.Width=.PageCount*(Thisform.ycont.container1.Width)
.Top=Thisform.ycont.Top+Thisform.ycont.Height-12
.ZOrder(1)
Endwith
Endproc
Enddefine
*
*-- EndDefine: ypgf
Define Class asup As Container
Top = 12
Left = -3
Width = 120
Height =30
Picture = Home(1)+"graphics\icons\misc\misc05.ico"
BackStyle = 0
BorderWidth = 0
MousePointer = 15
Name = "asup"
Add Object image1 As Image With ;
Picture = "aquatab.bmp", ;
Height = 40, ;
Left = 4, ;
Top = 0, ;
Width = 112, ;
stretch=2, ;
borderstyle=1,;
Name = "Image1"
Add Object command1 As CommandButton With ;
Top = -2, ;
Left = 84, ;
Height = 40, ;
Width = 37, ;
Caption = "", ;
Style = 1, ;
Name = "Command1"
Add Object label1 As Label With ;
FontSize = 8, ;
BackStyle = 0, ;
Caption = "Caption1", ;
Height = 25, ;
Left = 42, ;
Top = 6, ;
Width = 61, ;
Name = "Label1"
Add Object image2 As Image With ;
Picture =Home(1)+ "graphics\icons\misc\face05.ico", ;
Stretch = 2, ;
BackStyle = 0, ;
Height = 16, ;
Left = 22, ;
Top = 5, ;
Width = 16, ;
Name = "Image2"
Procedure Init
With This.command1
.Left=-10
.Top=-10
.Width=.Parent.Width+20
.Height=.Parent.Height+20
.ZOrder(0)
.MousePointer=15
Endwith
Bindevent(This.command1,"mousedown",Thisform,"my2")
Endproc
Enddefine
*
*-- EndDefine: asup
Click on code to select [then copy] -click outside to deselect
*5* created on sunday 30 of april 2017
*subclassing tabs with shapes and polypoint
Create Cursor yhm (ximage 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
_Screen.WindowState=1
_Screen.AddProperty("act",1) &&used to save the active atcual tab
Publi yform
yform=Newobject("asup")
yform.Show
Read Events
Retu
*
Define Class asup As Form
Top = 0
Left = 0
Height = 420
Width = 700
ShowWindow=2
AutoCenter = .T.
Caption = "Form1"
Name = "Form1"
Add Object pageframe1 As PageFrame With ;
anchor=15,;
PageCount = 7, ;
Top = 32, ;
Left = 24, ;
Width = 493, ;
Height = 197, ;
Tabs = .F., ;
Themes = .F., ;
Name = "Pageframe1"
Add Object ycont0 As Container With ;
Top = 12, ;
Left = 24, ;
Width = 637, ;
Height = 24, ;
BackStyle = 0, ;
BorderWidth = 0, ;
Name = "ycont0"
Procedure pageframe1.Init
With This
.Width=500
.Height=350
For i=1 To .PageCount
.Pages(i).BackColor=Rgb(255*Rand(),255*Rand(),255*Rand())
Endfor
.ZOrder(1)
For i=1 To .PageCount
.Pages(i).AddObject("image1","image")
With .Pages(i).image1
.Left=20
.Top=20
.Width=.Parent.Parent.Width-40
.Height=.Parent.Parent.Height-40
.Stretch=2
Try
Skip
Catch
Locate
Endtry
If Empty(ximage)
Locate
Endi
.PictureVal=yloadImg(ximage)
.Visible=.T.
Endwith
Endfor
.Refresh
Endwith
Endproc
Procedure ycont0.Init
Local N
N=Thisform.pageframe1.PageCount
With This
For i=1 To N
.AddObject("ytab"+Trans(i),"ytab")
With Eval(".ytab"+Trans(i))
.Width=Int(Floor(Thisform.pageframe1.Width/(N)))
.shape1.Width=.Width
.label1.Caption="Page"+Trans(i)
If i=1
.Left=1
Else
.Left= Eval("thisform.ycont0.ytab"+Trans(i-1)+".left")+Eval("thisform.ycont0.ytab"+Trans(i-1)+".width")-7
Endi
.Top=0
.Height=Thisform.ycont0.Height+10
.ZOrder(1)
Bindevent(.shape1,"mousedown",Thisform,"my")
Bindevent(.label1,"mousedown",Thisform,"my")
.Refresh
.Visible=.T.
Endwith
Endfor
Endwith
Thisform.pageframe1.ActivePage=1
This.ytab1.shape1.MouseDown(1)
Endproc
Procedure my
Lparameters nButton, nShift, nXCoord, nYCoord
*--- aevent create an array laEvents
Aevents( myArray, 0)
*--- reference the calling object
loObject = myArray[1]
x=Int(Val(Substr(loObject.Parent.Name,5)))
_Screen.act=m.x
Thisform.pageframe1.ActivePage=m.x
For i=1 To Thisform.pageframe1.PageCount
o=Eval("thisform.ycont0.ytab"+Trans(i))
o.shape1.FillColor=Rgb(0,255,0)
Endfor
loObject.Parent.shape1.FillColor=Thisform.pageframe1.Pages(x).BackColor
With loObject.Parent.Parent.Parent.pageframe1.Pages(x).image1
.Left=20
.Top=20
.Width=.Parent.Parent.Width-40
.Height=.Parent.Parent.Height-40
Endwith
Endproc
Procedure Resize
u="thisform.ycont0.ytab"+Trans(_Screen.act)+".shape1.mousedown(1)"
&u
Endproc
Procedure Destroy
Clea Events
Endproc
Enddefine
*
*-- EndDefine: asup
Define Class ytab As Container
Top = 288
Left = 204
Width = 105
Height = 24
BackStyle = 0
BorderWidth = 0
Name = "Container2"
Add Object shape1 As Shape With ;
Top = 2, ;
Left = 3, ;
Height = 20, ;
Width = 100, ;
DrawMode = 13, ;
FillStyle = 0, ;
BackColor = Rgb(255,255,255), ;
FillColor = Rgb(255,255,255), ;
BorderColor = Rgb(0,0,0), ;
mousepointer=15 , ;
backstyle=1,;
Name = "Shape1"
Add Object label1 As Label With ;
top=4,;
left=10,;
width=80,;
height=20,;
autosize=.T.,;
forecolor=0,;
mousepointer=15,;
backstyle=0,;
name="label1"
Procedure Init
Thisform.DrawWidth=4
With This.shape1
.AddProperty("Points[4,2]")
Dimension .Points[4,2]
.Points[1,1] = 0
.Points[1,2] = 0
.Points[2,1] = 100
.Points[2,2] = 0
.Points[3,1] = 90
.Points[3,2] = 100
.Points[4,1] = 10
.Points[4,2] = 100
.Polypoints = "this.Points"
.Rotation=180
.SpecialEffect=2
.FillColor=Rgb(0,255,0)
.BorderWidth=2
.FillStyle=0 &&7
.Height=.Parent.Height+5
Endwith
This.label1.Left=10
Endproc
Procedure shape1.Click
N=Int(Val(Substr(This.Name,6)))
Thisform.pageframe1.ActivePage=N
Endproc
Enddefine
*
*-- EndDefine: ytab
*internet must be connected
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 play with polypoint shape property and draw advanced tabs with Beziers curves...can overlap container class to make some visual effects.
Click on code to select [then copy] -click outside to deselect
*6* created on sunday 30 of april 2017
*its the same code as previous one but with native shapes objects in tabs.the shape curvature is used to round the shape corners.
Create Cursor yhm (ximage 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
_Screen.WindowState=1
_Screen.AddProperty("act",1) &&used to save the active atcual tab
Publi yform
yform=Newobject("asup")
yform.Show
Read Events
Retu
*
Define Class asup As Form
Top = 0
Left = 0
Height = 420
Width = 700
AutoCenter = .T.
ShowWindow=2
Caption = "Form1"
Name = "Form1"
Add Object pageframe1 As PageFrame With ;
Anchor=15, ;
PageCount = 7, ;
Top = 32, ;
Left = 24, ;
Width = 600, ;
Height = 197, ;
Tabs = .F., ;
Themes = .F., ;
Name = "Pageframe1"
Add Object ycont0 As Container With ;
Top = 12, ;
Left = 24, ;
Width = 637, ;
Height = 24, ;
BackStyle = 0, ;
BorderWidth = 0, ;
Name = "ycont0"
Procedure pageframe1.Init
DoDefault()
With This
.Width=500
.Height=350
For i=1 To .PageCount
.Pages(i).BackColor=Rgb(255*Rand(),255*Rand(),255*Rand())
Endfor
.ZOrder(1)
For i=1 To .PageCount
.Pages(i).AddObject("image1","image")
With .Pages(i).image1
.Left=20
.Top=20
.Width=.Parent.Parent.Width-40
.Height=.Parent.Parent.Height-40
.Stretch=2
Try
Skip
Catch
Locate
Endtry
If Empty(ximage)
Locate
Endi
.PictureVal=yloadImg(ximage)
.Visible=.T.
Endwith
Endfor
.Refresh
Endwith
Endproc
Procedure ycont0.Init
Local N
N=Thisform.pageframe1.PageCount
With This
Local m.delta
m.delta=0
For i=1 To N
.AddObject("ytab"+Trans(i),"ytabsh")
With Eval(".ytab"+Trans(i))
.Width=Int(Floor(Thisform.pageframe1.Width/(N)))
.shape1.Width=.Width
.shape1.BackColor=Thisform.pageframe1.Pages(i).BackColor
.label1.Caption="Page"+Trans(i)
If i=1
.Left=3
Else
.Left= Eval("thisform.ycont0.ytab"+Trans(i-1)+".left")+Eval("thisform.ycont0.ytab"+Trans(i-1)+".width")-m.delta
Endi
.Top=0
.Height=Thisform.ycont0.Height+15 &&to hide the bottom shape draw with container
.ZOrder(1)
Bindevent(.shape1,"mousedown",Thisform,"my")
Bindevent(.label1,"mousedown",Thisform,"my")
.Refresh
.Visible=.T.
Endwith
Endfor
Thisform.pageframe1.Top=This.Top+This.Height-2
Endwith
Thisform.pageframe1.ActivePage=1
This.ytab1.shape1.MouseDown(1)
Endproc
Procedure Resize
u="thisform.ycont0.ytab"+Trans(_Screen.act)+".shape1.mousedown(1)"
&u
Endproc
Procedure my
Lparameters nButton, nShift, nXCoord, nYCoord
*--- aevent create an array laEvents
Aevents( myArray, 0)
*--- reference the calling object
loObject = myArray[1]
x=Int(Val(Substr(loObject.Parent.Name,5)))
Thisform.pageframe1.ActivePage=m.x
With loObject.Parent.Parent.Parent.pageframe1.Pages(x).image1
.Left=20
.Top=20
.Width=.Parent.Parent.Width-40
.Height=.Parent.Parent.Height-40
Endwith
Endproc
Procedure Destroy
Clea Events
Endproc
Enddefine
*
*-- EndDefine: asup
*
Define Class ytabsh As Container
Top = 227
Left = 30
Width = 40
Height = 27
Name = "Container3"
Add Object shape1 As Shape With ;
anchor = 15,;
left=0, ;
top=0, ;
width = 40, ;
height = 27, ;
curvature=30, ;
backcolor = Rgb(255,0,0), ;
borderwidth=0, ;
visible = .T., ;
mousepointer=15,;
name="shape1"
Add Object label1 As Label With ;
AutoSize = .T., ;
Alignment = 2, ;
Caption = "Page1", ;
Height = 17, ;
Left = 46, ;
Top = 12, ;
Width = 38, ;
ForeColor = 0, ;
mousepointer=15,;
Name = "Label1"
Procedure Init
With This
.BorderWidth=0
.BackStyle=0
With .shape1
.Width=.Parent.Width
Endwith
With .label1
.AutoSize=.T.
.Left=10 &&(.parent.width-.width)/2
.Top=(.Parent.Height-.Height)/2
.ZOrder(0)
.BackStyle=0
Endwith
Endwith
Endproc
Procedure shape1.Click
N=Int(Val(Substr(This.Name,6)))
Thisform.pageframe1.ActivePage=N
Endproc
Enddefine
*
*-- EndDefine: ytabsh
*internet must be connected
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
*7* created on saturday 20 of may 2017 *!* A vfp pageframe can be decorated as well as modern ones (as that we see on web apps). *!* this code uses 2 methods *!* 1.a container with a background image .Each zone can be overlapped with 1 transparent shape. *!* choose a relevant image as the one i made here with 10 buttons. *!* the pageframe is then instancied with 8 buttons. *!* 2.a container with labels only and one shape (as web Bootstrap does) *!* in 2 cases the shape control is created for the purpose at mouseEnter and destroyed at mouseLeave event. *!* i used the great vfp function bindevent to bind all controls with 3 events: *!* -mouseEnter *!* -mouseLeave *!* -MouseDown *!* Of course in the page frame can fill with any vfp control or even olecontrols.Rightclick on any page to fire a demo contextuem menu. *!* -on button item10 rightclick can fire the same menu(can customize) *!* -can show or hide the form titlebar. *!* Press ESC to exit form (i made also in each page a png button exit) *!* tweaking the ytbar1 or ytbar2 in method "my" can use only as main menu (without refrering to the pageframe). *!*the demo uses 2 themed toolbars as container (can keep one only for use or build equivalent ones). set defa to addbs(justpath(sys(16,1))) *download one image used in code(can change on PEM on the form to any image on disc) Declare Integer Sleep In kernel32 Integer Declare Integer URLDownloadToFile In urlmon.Dll Integer pCaller, String szURL, String szFileName, Integer dwReserved, Integer lpfnCB Declare Integer DeleteUrlCacheEntry In wininet String lpszUrlName lcDownloadURL = "http://img.over-blog-kiwi.com/1/43/54/07/20170521/ob_18d2cb_1.png" lcDownloadLoc ="1.png" lnResult = DeleteUrlCacheEntry(lcDownloadURL) lnResult = URLDownloadToFile(0, lcDownloadURL, lcDownloadLoc , 0,0) If lnResult = 0 Wait Window "Download "+lcDownloadLoc +" Complete" Nowait *Else *!* Messagebox("Download fails") Endi Local m.myvar TEXT to m.myvar pretext 7 noshow A vfp pageframe can be decorated as well as modern ones (as that we see on web apps). this code uses 2 methods 1.a container with a background image .Each zone can be overlapped with 1 transparent shape. choose a relevant image as the one i made here with 10 buttons. the pageframe is then instancied with 8 buttons. 2.a container with labels only and one shape (as web Bootstrap does) in 2 cases the shape control is created for the purpose at mouseEnter and destroyed at mouseLeave event. i used the great vfp function bindevent to bind all controls with 3 events: -mouseEnter -mouseLeave -MouseDown Of course in the page frame can fill with any vfp control or even olecontrols.Rightclick on any page to fire a demo contextuem menu. -on button item9 rightclick can fire the same menu(can customize) -can show or hide the form titlebar. -Press ESC key to exit form.(i made also in each page a png button exit) -on button item10 rightclick can fire the same menu(can customize) -tweaking the ytbar1 or ytbar2 in method "my" can use only as main menu (without refering to the pageframe). the demo uses 2 themed toolbars as container (can keep one only for use or build equivalent ones). ENDTEXT _Screen.AddProperty("yhelp",m.myvar) Publi yform yform=Newobject("ybars") yform.Show Read Events Retu * Define Class ybars As Form Height = 730 Width = 1009 ShowWindow = 2 ShowTips=.T. AutoCenter = .T. KeyPreview=.t. Caption = "Modern use of vfp pageframes" BackColor = Rgb(0,0,0) Sign = 1 ybackc_shape = 255 yforec_label = (Rgb(0,0,255)) Name = "Form1" Add Object ytbar1 As ytbar1 With ; Top = 1, ; Left = 0, ; Width = 1010, ; Height = 47, ; Name = "ytbar1" Add Object pageframe1 As PageFrame With ; PageCount = 7, ; BorderWidth = 0, ; Top = 60, ; Left = 12, ; Width = 996, ; Height = 600, ; Tabs = .F., ; Themes = .F., ; Name = "Pageframe1" Add Object ytbar2 As ytbar2 With ; Top = 676, ; Left = 5, ; Width = 982, ; Height = 48, ; BackStyle = 1, ; BorderWidth = 1, ; BackColor = Rgb(0,0,0), ; Name = "ytbar2" PROCEDURE KEYPRESS && esc to release the form here LPARAMETERS nKeyCode, nShiftAltCtrl if nkeycode=27 thisform.release endi endproc PROCEDURE yedmenu SET COLOR OF SCHEME 1 TO N+/w*,GR+/N*,,,,W+/R Define Popup raccourci SHORTCUT Relative From Mrow(),Mcol() color scheme 1 DEFINE BAR _med_slcta OF raccourci PROMPT "Sélectionner tout" ; KEY CTRL+A, "Ctrl+A" ; PICTRES _med_slcta ; MESSAGE "Sélectionne tout le texte ou tous les éléments de la fenêtre active" DEFINE BAR _med_paste OF raccourci PROMPT "Coller" ; KEY CTRL+V, "Ctrl+V" ; PICTRES _med_paste ; MESSAGE "Place le contenu du Presse-papiers au point d'insertion" DEFINE BAR _med_copy OF raccourci PROMPT "Copier" ; KEY CTRL+C, "Ctrl+C" ; PICTRES _med_copy ; MESSAGE "Copie la sélection et la place dans le Presse-papiers" DEFINE BAR _med_cut OF raccourci PROMPT "Couper" ; KEY CTRL+X, "Ctrl+X" ; PICTRES _med_cut ; MESSAGE "Enlève la sélection et la place dans le Presse-papiers" DEFINE BAR _med_redo OF raccourci PROMPT "Rétablir" ; KEY CTRL+R, "Ctrl+R" ; PICTRES _med_redo DEFINE BAR _med_undo OF raccourci PROMPT "Annuler" ; KEY CTRL+Z, "Ctrl+Z" ; PICTRES _med_undo ; MESSAGE "Annule la dernière modification" ACTIVATE POPUP raccourci ENDPROC Procedure my1 Lparameters nButton, nShift, nXCoord, nYCoord *--- aevent create an array laEvents Aevents( myArray, 0) *--- reference the calling object loObject = myArray[1] loObject.ForeColor=Thisform.yforec_label loObject.FontBold=.T. loObject.FontUnderline=.T. loObject.MousePointer=15 With loObject.Parent Try .AddObject("yshp","shape") Catch Endtry With .yshp .BackColor=Thisform.ybackc_shape .ZOrder(0) .Curvature=15 .Left=loObject.Left-5 .Top=4 .Width=loObject.Width+10 .Height=loObject.Parent.Height-8 .Curvature=15 .MousePointer=15 .Visible=.T. Endwith Endwith loObject.ZOrder(0) 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.Parent .RemoveObject("yshp") .Refresh Endwith With loObject .ForeColor=Rgb(255,255,255) .FontBold=.F. .FontUnderline=.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 m.x m.x=Int(Val(Substr(loObject.Name,6))) Do Case Case Lower(loObject.Parent.Name)=="ytbar1" If x<=Thisform.pageframe1.PageCount Thisform.pageframe1.ActivePage=m.x Thisform.ydrawL("Hello World",x) Endi Case Lower(loObject.Parent.Name)=="ytbar2" If x<=9 Thisform.pageframe1.ActivePage=m.x Thisform.ydrawL("Hello World",x) Endi Endcase if m.x=9 &&fire contextuel menu in button10 thisform.yedMenu() endi if m.x=10 With Thisform .TitleBar=Iif(.TitleBar=1,0,1) If .TitleBar=0 .Height=.Height+33 Else .Height=.Height-33 Endi .refresh Endwith endi if x=11 &&help Local oshell oshell = Createobject('WScript.Shell') oshell.Popup(_Screen.yhelp,0, 'summary help', 0+32+4096) &&4,16,48,64... oshell=Null endi Endproc Procedure ydrawL &&draw "hello world" Lparameters xcaption,i Local m.delta,Sign Rand(-1) Thisform.Sign=Iif(Thisform.Sign=1,-1,1) m.delta=Thisform.Sign*Int(3 * Rand( ) + 3) With Thisform.pageframe1.Pages(i) Try .AddObject("yim","yexit") .yim.visible=.t. .AddObject("yhello","label") .AddObject("yhello1","label") Catch Endtry With Eval (".yhello") .FontSize=72 .FontBold=.T. .FontItalic=.T. .AutoSize=.T. .Alignment=0 .Caption=xcaption+" page "+Trans(i) .Left=60 .Top=180 .BackStyle=0 Rand(-1) .ForeColor=0 .ZOrder(1) .Visible=.T. Endwith With Eval (".yhello1") .FontSize=72 .FontBold=.T. .FontItalic=.T. .AutoSize=.T. .Alignment=0 .Caption=xcaption+" page "+Trans(i) .Left=60+m.delta .Top=180+m.delta .BackStyle=0 Rand(-1) .ForeColor=Rgb(255*Rand(),255*Rand(),255*Rand()) .ZOrder(0) .Visible=.T. Endwith .Refresh Endwith Endproc Procedure Activate Thisform.ytbar1.label1.MouseDown(1) Endproc Procedure Init Thisform.pageframe1.PageCount=Thisform.ytbar1.ypagecount Thisform.ybackc_shape=255 &&rgb(0,255,0) &&.. Thisform.yforec_label=Rgb(0,0,255) With This.pageframe1 .Anchor=15 .Left=0 .Top=.Parent.ytbar1.Top+.Parent.ytbar1.Height-1 .Width=.Parent.Width .ZOrder(1) Rand(-1) For i=1 To .PageCount .Pages(i).BackColor=Rgb(255*Rand(),255*Rand(),255*Rand()) bindevent(.pages(i),"rightclick",thisform,"yedmenu") Endfor Endwith This.Resize This.WindowState=2 Endproc Procedure Resize With Thisform With .ytbar1 .Top=0 .Left=0 .Width=.Parent.Width Endwith With .pageframe1 .Left=0 .Top=.Parent.ytbar1.Top+.Parent.ytbar1.Height-2 .Width=.Parent.Width Endwith With .ytbar2 .Left=5 .Top=.Parent.pageframe1.Top+.Parent.pageframe1.Height+30 .Width=.Parent.Width-10 Endwith Endwith Endproc Procedure Destroy yform=Null Release yform _Screen.yhelp=Null Release _Screen.yhelp Clea Events Endproc Enddefine * *-- EndDefine: ybars * * DEFINE CLASS yTbar1 AS container Top = 0 Left = 0 Width = 996 Height = 55 Name = "ytBar1" ypagecount=11 ADD OBJECT image1 AS image WITH ; Picture = "1.png", ; Height = 54, ; Left = 0, ; Top = 0, ; Width = 995, ; Name = "Image1" ADD OBJECT label1 AS label WITH ; Caption = "Item1", ; Height = 25, ; Left = 14, ; Top = 11, ; Width = 73, ; Name = "Label1" ADD OBJECT label2 AS label WITH ; Caption = "Item2", ; Height = 25, ; Left = 102, ; Top = 11, ; Width = 73, ; Name = "Label2" ADD OBJECT label3 AS label WITH ; Caption = "Item3", ; Height = 25, ; Left = 192, ; Top = 11, ; Width = 73, ; Name = "Label3" ADD OBJECT label4 AS label WITH ; Caption = "Item4", ; Height = 25, ; Left = 282, ; Top = 12, ; Width = 73, ; Name = "Label4" ADD OBJECT label5 AS label WITH ; Caption = "Item5", ; Height = 25, ; Left = 383, ; Top = 9, ; Width = 73, ; Name = "Label5" ADD OBJECT label6 AS label WITH ; Caption = "Item6", ; Height = 25, ; Left = 471, ; Top = 9, ; Width = 73, ; Name = "Label6" ADD OBJECT label7 AS label WITH ; Caption = "Item7", ; Height = 25, ; Left = 563, ; Top = 8, ; Width = 73, ; Name = "Label7" ADD OBJECT label8 AS label WITH ; Caption = "Item8", ; Height = 25, ; Left = 654, ; Top = 9, ; Width = 73, ; Name = "Label8" ADD OBJECT label9 AS label WITH ; Caption = "Item9", ; Height = 25, ; Left = 743, ; Top = 9, ; Width = 73, ; Name = "Label9" ADD OBJECT label10 AS label WITH ; Caption = "Titlebar", ; Height = 25, ; Left = 828, ; Top = 7, ; Width = 73, ; Name = "Label10" ADD OBJECT label11 AS label WITH ; Caption = "Help", ; Height = 25, ; Left = 911, ; Top = 8, ; Width = 73, ; Name = "Label11" PROCEDURE Init With This .BackStyle=0 .BorderWidth=0 .Left=0 .Top=0 .Width=.Parent.Width .Anchor=0 With .image1 .Anchor=15 .Left=0 .Top=0 Endwith .SetAll("backstyle",0,"label") .SetAll("mousepointer",15,"label") .SetAll("forecolor",Rgb(255,255,255),"label") .SetAll("alignment",2,"label") .SetAll("top",20,"label") j=0 For i=1 To .ControlCount If Lower(.Controls(i).Class)=="label" j=j+1 Bindevent(.Controls(i),"mouseEnter",Thisform,"my1") Bindevent(.Controls(i),"mouseLeave",Thisform,"my2") Bindevent(.Controls(i),"mouseDown",Thisform ,"my") Endi Endfor This.ypagecount=j Endwith ENDPROC ENDDEFINE * *-- EndDefine: ytbar1 * Define Class ytbar2 As Container Top = 676 Left = 5 Width = 982 Height = 48 BackStyle = 1 BorderWidth = 1 BackColor = Rgb(0,0,0) Name = "ytbar2" Add Object shape1 As Shape With ; Top = 0, ; Left = -17, ; Height = 48, ; Width = 980, ; Anchor = 15, ; Curvature = 15, ; BackColor = Rgb(0,0,0), ; Name = "Shape1" Add Object label1 As Label With ; Caption = "Item1", ; Height = 35, ; Left = 8, ; Top = 2, ; Width = 73, ; Name = "Label1" Add Object label2 As Label With ; Caption = "Item2", ; Height = 25, ; Left = 96, ; Top = 2, ; Width = 73, ; Name = "Label2" Add Object label3 As Label With ; Caption = "Item3", ; Height = 25, ; Left = 185, ; Top = 2, ; Width = 73, ; Name = "Label3" Add Object label4 As Label With ; Caption = "Item4", ; Height = 25, ; Left = 278, ; Top = 2, ; Width = 73, ; Name = "Label4" Add Object label5 As Label With ; Caption = "Item5", ; Height = 25, ; Left = 367, ; Top = 2, ; Width = 73, ; Name = "Label5" Add Object label6 As Label With ; Caption = "Item6", ; Height = 25, ; Left = 460, ; Top = 2, ; Width = 73, ; Name = "Label6" Add Object label7 As Label With ; Caption = "Item7", ; Height = 25, ; Left = 548, ; Top = 2, ; Width = 73, ; Name = "Label7" Add Object label8 As Label With ; Caption = "Item8", ; Height = 25, ; Left = 640, ; Top = 2, ; Width = 73, ; Name = "Label8" Add Object label9 As Label With ; Caption = "Item9", ; Height = 25, ; Left = 734, ; Top = 2, ; Width = 73, ; Name = "Label9" Add Object label10 As Label With ; Caption = "TITLEBAR", ; Height = 25, ; Left = 821, ; Top = 2, ; Width = 73, ; Name = "Label10" Add Object label11 As Label With ; Caption = "Help", ; Height = 25, ; Left = 908, ; Top = 2, ; Width = 73, ; Name = "Label11" Procedure Init With This .Anchor=0 .BackStyle=0 .Left=5 .BorderWidth=0 .Top=.Parent.pageframe1.Top+.Parent.pageframe1.Height+1 .Width=.Parent.Width-10 .SetAll("backstyle",0,"label") .SetAll("mousepointer",15,"shape") .SetAll("Forecolor",Rgb(255,255,255),"label") .SetAll("height",30,"label") .setall("top",10,"label") .SetAll("alignment",2,"label") j=0 For i=1 To .ControlCount If Lower(.Controls(i).Class)=="label" j=j+1 Bindevent(.Controls(i),"mouseEnter",Thisform ,"my1") Bindevent(.Controls(i),"mouseLeave",Thisform ,"my2") Bindevent(.Controls(i),"mouseDown",Thisform ,"my") Endi Endfor .refresh Endwith Endproc Procedure shape1.Init With This .Anchor=15 .backstyle=0 .Left=0 .Top=0 .ZOrder(1) Endwith Endproc Enddefine * *-- EndDefine: ytbar2 define class yexit as image left=800 top=540 mousepointer=15 backstyle=0 stretch=0 name="yim" procedure init text to m.myvar noshow iVBORw0KGgoAAAANSUhEUgAAAEQAAAAkCAYAAAAw55zoAAAFCElEQVRoge2ae1BUZRiHn7O7riywIBcBUa6CYupAYOXkhKmICSUoKVNOg2nZxUmzxdTGFE2zJs2srLEMR0eb0RxExzJtzLsyoGLihUzipgRykW1XFtjdc/pjhWB1sj/OujXsM/PO7L7fznt+8+7v+84533yCJEkAnCupSt3/88U3Kqob4/QGUyA9AG+tpi4i1K94Skr8ypiooJMAgiRJfLu7cPXZoz8smjFgJ1Ee5WiUrc7W+kBosWooNUaxuTqTcSmpi9KfivtQOHuhMnX7ptx970W/j1owO1ujU2gR3Vh8Ncf6lm7mSGVYTPL6dPW66ABVHaJIjwylZEGrNCiO3xzmpfq9qj4hNKAcS880RycD1Vf5rqx2lOpPQ2uAyr8Vs+hsSc5Fyy0ab90OUQFYLM6W899BBWDu4dOlKy6H2OFyiB0uh9jhcogdDnFIWNZWfEe+cFe+rbGCy0si7l9AUDJk6SXUfmFU5E5Hfz5PXoH/gEMc0ssv8p75PwyQug3yM+9TQCGAUk27FRYeFBmhh+dmZxOSsZqGgm2Ub35RXsEdKEEBNofIGXdeoFm7di2CIHRGREQEkvQvarRbKNRFEtlXw978fCQRFG59EJQqTjX4sPyI/Jo7ZolDHNLREIBpMfB6fPdxv1GzGDTrK9r1dZxdHIvZUE//ifMZ+PxH3Dy9g9IvppOw+gLXcwdzcc0kQp5ZiM/QMQCkpaWRlibRcCafS+smyyu8t4MdotPp2HFFYvR2W2gHj8VigRtHttFYU05vn36Uxi/HoAwgfEoOoigx9uWVrDgBKk9fFCo1q85p0Zusd2k/ViXyzhH5HaIAm0PkjK4O6crbxwSKaqDd1EbZ5jcByJo1m34vbUXl7sWXGz6ntPQKmdHAnRqiBF/PGc+mdasA2LNnD4IgkJGRgdzawUF3ma5rSHZ2drexJ0farldftI+rp/Yz6PGJJCROoLmpkSXLcng6HILdO/tha4oVRvf/+/tjgbDkUdtnubU7fA2ZFA4zYrqPm82AQklgUHBnzkPrRVRoMFMD9LbxLjUsVrB2mTWi5LhnJ4c6BGwbMPeqH5U+B+/IWC7+UkyT3kBiYiIffPwpJUvH09uj+29FK1jNtiLh4eGo3dxRemppa66TVzgOdohOp0On03XmW5vryUsPwM0nkKFZKwCYO1+Hh8XAE0cLSUpKYt+WKQRW53VrqsUK+uprAMTGxnKi8jY3in5i77xkvNXyarfdZczyhuFG+T0vZrQIvHoSBk9bQC8PL/J27eLw4cMMbTpD8e5vEEWRmQuWUVAL7UY9VqsVo9GI1QJlB3ZwOm8Lzc3NtLS0kPtjARsuy6sbQJg6e6M04fwr8rYZ2FQGBY135z1V8Ek87KyCg7WQ4AOvRdvGtpTDiXror4Gc4fDuBahthbmDYHgfsIiwtQKKb4FVguQgSB8gn+YDcRttDRlXJH9D/o8cemTjnTXE9frfiWs/xA7XfogdLofY4XKIHS6H2KHy1mrq2tAEKswmZ2txKhZ3P/x9PStVA8P7nrnuE5WqqSlxtianYvSP4aHooOOqyRPj3l9+KjOlb81vgmDuGedC7BHdtBgefrY9IyV+pfKz9WuqVZ5epsK2kDFSi1EhtZqgzeT0IwoPIswaP0yh8RiS5rRnZSXPixsWckDoOFJVVlE/4vtDJfNLr9WOamgyhjn5T3sg+Pt6Vg6JDjqekRK/Mjioz68AfwFylycUM2AeIQAAAABJRU5ErkJggg== endtext this.PictureVal=strconv(m.myvar,14) endproc procedure click thisform.release endproc enddefine
the demo uses 2 themed toolbars as container (can keep one only for use).
Click on code to select [then copy] -click outside to deselect
*8* created on sunday 03 of december 2017
*this codes builds a special pageframe with some styles and events.
*download these 3 images and save as 1.png,2.png,3.png in the source folder.it used in code.
*it can desserve as a menu when clicking any item can fire custom action.
*these actions (not coded) can be in a permanent table describing the location in the pageframe (page,label num,action)
****download 3 images used in code
local m.ydownl
m.ydownl=.t. && one downoad turn this to .f.
if m.ydownl=.t.
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 3
Do Case
Case i=1
lcUrl="http://img.over-blog-kiwi.com/1/43/54/07/20171203/ob_99c88d_1.png"
lcDownloadLoc="1.png"
Case i=2
lcUrl="http://img.over-blog-kiwi.com/1/43/54/07/20171203/ob_584533_2.png"
lcDownloadLoc="2.png"
Case i=3
lcUrl="http://img.over-blog-kiwi.com/1/43/54/07/20171203/ob_c2cd60_3.png"
lcDownloadLoc="3.png"
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
endi
**********end downloads****************
Publi oform
oform=Newobject("yform")
oform.Show
Read Events
Retu
Define Class yform As Form
Top = 0
Left = 0
Height = 680
Width = 780
ShowWindow=2
BorderStyle=0
autocenter=.t.
Caption = "Form1"
Name = "form1"
Add Object ylab As Label With ;
AutoSize = .T., ;
Left = 20, ;
Top = 10, ;
FontBold = .T., ;
FontName = "Calibri", ;
FontSize = 16, ;
FontItalic=.T., ;
Alignment = 0, ;
BackStyle = 0, ;
Caption = "", ;
Height = 31, ;
ForeColor = Rgb(0,0,81), ;
Name = "ylab"
Add Object container1 As Container With ;
Top = 50, ;
Left = 0, ;
Width = 394, ;
Height =570, ;
BackStyle = 1, ;
BorderWidth = 0, ;
BackColor =Rgb(255,255,255), ;
Name = "Container1"
Procedure Init
Sys(2002) &&no cursor
With Thisform.container1
.AddObject ("label1","label" )
With .label1
.AutoSize = .T.
.FontBold = .T.
.FontName = "Calibri"
.FontSize = 22
.FontItalic=.T.
.Alignment = 2
.BackStyle = 0
.Caption = "Most Popular"
.Height = 31
.Left = 91
.Top = 3
.Width = 138
.ForeColor = Rgb(0,0,81)
.Name = "Label1"
.Visible=.T.
Endwith
.AddObject("image1","image")
With .image1
.Picture = "1.png"
.Stretch = 2
.Height = 48
.Left = 292
.Top = 8
.Width = 48
.Name = "Image1"
.Visible=.T.
Endwith
.AddObject("ypgf","ypgf")
With .ypgf
.Name="ypgf"
.Visible=.T.
Endwith
Endwith
Procedure Destroy
set curs on
Clea Events
Endproc
Enddefine
*endDefine yform
*
Define Class ypgf As PageFrame
ErasePage = .T.
PageCount = 3
Top = 60
Left = 12
Width = 372
Height = 470
Themes = .F.
Name = "Pageframe1"
Page1.FontBold = .T.
Page1.FontItalic = .T.
Page1.FontSize = 16
Page1.Caption = "Viewed"
Page1.BackColor = Rgb(230,230,230)
Page1.Name = "Page1"
Page2.FontBold = .T.
Page2.FontItalic = .T.
Page2.FontSize = 16
Page2.Caption = "Shared"
Page2.Name = "Page2"
Page3.FontBold = .T.
Page3.FontItalic = .T.
Page3.FontSize = 16
Page3.Caption = "Commented"
Page3.Name = "Page3"
Procedure Init
DoDefault()
Local m.hh,m.nn
With This
For j=1 To .PageCount
With .Pages(j)
Do Case
Case j=1
nn=5
Case j=2
nn=4
Case j=3
nn=3
Otherwise
nn=5
Endcase
For i=1 To m.nn
.AddObject ("ycnts"+Trans(i),"ycnts")
With Eval(".ycnts"+Trans(i))
DoDefault()
.label1.Caption=Trans(i)
.label1.ForeColor =Rgb(255,128,64)
Do Case
Case j=1
.label2.ForeColor=Rgb(255,128,64)
Case j=2
.label2.ForeColor=Rgb(150,0,0)
Case j=3
.label2.ForeColor=Rgb(0,0,160)
Otherwise
.label2.ForeColor=Rgb(255,128,64)
Endcase
.Refresh
If i=1
.Top = 0
m.hh=.Height
Else
.Top=(i-1)*m.hh
Endi
.Left = 4
.Width = 360
.Height = 80
.BackStyle = 0
.BorderWidth = 0
.BackColor = Rgb(255,255,255)
.Name = "ycnts"+Trans(i)
.Refresh
.Visible=.T.
Endwith
Endfor
Endwith
Endfor
Endwith
Endproc
Procedure Click
With This
Try
.Parent.image1.Picture=Trans(.ActivePage)+".png"
Catch
.Parent.image1.Picture="1.png"
Endtry
This.Parent.label1.ForeColor=Rgb(0,255*Rand(),0)
Endwith
Endproc
Enddefine
*endDefine ypgf
*
Define Class ycnts As Container
Top = 0
Left =0
Width = 360
Height = 80
BackStyle = 0
BorderWidth = 0
BackColor = Rgb(255,255,255)
Name = "ycnts"
Add Object label1 As Label With ;
FontName = "Calibri", ;
FontSize = 42, ;
Alignment = 2, ;
Caption = "1", ;
Height = 73, ;
Left = 0, ;
MousePointer = 15, ;
Top = 1, ;
Width = 60, ;
ForeColor = Rgb(255,128,64), ;
BackColor = Rgb(230,230,230), ;
Name = "Label1"
Add Object label2 As Label With ;
FontName = "Script MT Bold", ;
FontSize = 16, ;
WordWrap = .T., ;
Caption = "Lorem ipsum dolor sit amet, consectetur adipiscing elit. Proin vel risus eget lorem feugiat", ;
Height = 73, ;
Left = 58, ;
MousePointer = 15, ;
Top = 0, ;
Width = 301, ;
ForeColor = Rgb(69,69,69), ;
BackColor = Rgb(230,230,230), ;
Name = "Label2"
Add Object line1 As Line With ;
Height = 0, ;
Left = 4, ;
Top = 77, ;
Width = 360, ;
BorderColor = Rgb(255,255,255), ;
Name = "Line1"
Procedure Init
DoDefault()
Bindevent(This.label1,"mouseDown",This,"my")
Bindevent(This.label2,"mousedown",This,"my")
Endproc
Procedure my
Lparameters nButton, nShift, nXCoord, nYCoord
*--- aevent create an array laEvents
Aevents( myArray, 0)
*--- reference the calling object
loObject = myArray[1]
*can build a permanent table with the fields |page,num,action] and fire actions to execute from here.
Thisform.ylab.Caption="thisform."+loObject.Parent.Parent.Parent.Parent.Name+"."+loObject.Parent.Parent.Parent.Name+"."+loObject.Parent.Parent.Name+"."+loObject.Parent.Name+'.'+loObject.Name+" clicked! do some code from here."
With Thisform.ylab
For i=1 To 10
.Visible=Iif(.Visible=.T.,.F.,.T.)
Inke(0.2)
Endfor
.Visible=.T.
Endwith
Endproc
Procedure label1.MouseLeave
Lparameters nButton, nShift, nXCoord, nYCoord
With This
.Left=.Left+2
.Top=.Top+2
.BackColor=Rgb(230,230,230)
.Parent.label2.BackColor=Rgb(230,230,230)
.ForeColor =Rgb(255,128,64)
Local m.xx
m.xx=.Parent.Parent.Parent.ActivePage
Do Case
Case m.xx=1
.Parent.label2.ForeColor=Rgb(255,128,64)
Case m.xx=2
.Parent.label2.ForeColor=Rgb(150,0,0)
Case m.xx=3
.Parent.label2.ForeColor=Rgb(0,0,160)
Otherwise
.Parent.label2.ForeColor=Rgb(255,128,64)
Endcase
Endwith
Endproc
Procedure label1.MouseEnter
Lparameters nButton, nShift, nXCoord, nYCoord
With This
.Left=.Left-2
.Top=.Top-2
.BackColor=Rgb(200,200,200)
.Parent.label2.BackColor=.BackColor
.ForeColor= Rgb(128,0,64)
.Parent.label2.ForeColor=.ForeColor
Endwith
Endpro
Procedure label2.MouseEnter
Lparameters nButton, nShift, nXCoord, nYCoord
This.Parent.label1.MouseEnter(1)
Endproc
Procedure label2.MouseLeave
Lparameters nButton, nShift, nXCoord, nYCoord
This.Parent.label1.MouseLeave(1)
Endproc
Enddefine
*
*-- EndDefine: ycnts
*Important:All Codes above are tested on VFP9SP2 & windows 10 pro.