Grid cosmetics part 3
[Post 278] this post continues the previous one (part1 and part2). its relative to vfp grid codes,as grid artificial borderwidth or bordercolor , vertical headers.... note: if want more grid cosmetics convert the relative cursor online to html and browse it in an embed 'shell.explorer.2' on the form with CSS styles wanted.(see previous post on beautifying tables). the post might continue with future other relative codes.
Click on code to select [then copy] -click outside to deselect
*1*created on sunday 30 of september 2018
*this is a solution to simulate a grid border (native border is vfp system window border and don't have any property to change the grid window color).
*include the grid in a container and adjust (procedure resize()).the bordercolor property of the container or picture can desserve this problem.
*can change the random grid border color by simple click on it here.
*can set a container image (as shipped in code ybg.png for ex. or any other)an empty image want to say "no picture)
*with this code can have a simple color border or an image colored border.All adjustable as wanted.
*(can also use a basic solution with a simple shape (zorder(1) always to send it back the grid).here can use curvature to play with round rectangle corners.)
PUBLIC oform
oform1=NEWOBJECT("ygrid_border_color")
oform1.Show
read events
RETURN
*
DEFINE CLASS ygrid_border_color AS form
Height = 296+40
Width = 700
ShowWindow = 2
AutoCenter = .T.
showtips=.T.
scalemode=3
Caption = "Click shapes to change random color, pîcture or container borderWidth.can resize the form/grid"
Name = "Form1"
ADD OBJECT container1 AS ycont WITH ;
Anchor = 15, ;
Top = 12, ;
Left = 30, ;
Width = 655, ;
Height = 265, ;
BackStyle = 0, ;
BorderWidth = 4, ;
MousePointer = 15, ;
BorderColor = RGB(255,128,64), ;
Name = "Container1"
ADD OBJECT shape1 AS shape WITH ;
Top = 300+14, ;
Left = 50, ;
Height = 13, ;
Width = 13, ;
Anchor = 768, ;
Curvature = 99, ;
MousePointer = 15, ;
ToolTipText = "Change random border color (or click on container border)", ;
BackColor = RGB(255,0,0), ;
Name = "Shape1"
ADD OBJECT shape2 AS shape WITH ;
Top = 300+14, ;
Left = 70, ;
Height = 13, ;
Width = 13, ;
Anchor = 768, ;
Curvature = 99, ;
MousePointer = 15, ;
ToolTipText = "Change container picture(empty=no picture)", ;
BackColor = RGB(0,0,255), ;
Name = "Shape2"
ADD OBJECT spinner1 AS spinner WITH ;
Height = 24,;
KeyboardHighValue = 20,;
KeyboardLowValue = 0,;
Left = 90,;
SpinnerHighValue = 20.00,;
SpinnerLowValue = 0.00,;
Top = 295+14,;
Width = 48,;
Anchor=768,;
Value=4,;
ToolTipText="container borderwidth (px)",;
Name = "Spinner1"
PROCEDURE shape1.Click
rand(-1)
thisform.container1.BorderColor=RGB(255*rand(),255*rand(),255*rand())
ENDPROC
PROCEDURE shape2.Click
WITH thisform.container1
.picture=getpict()
.BackStyle=1
thisform.resize()
endwith
ENDPROC
PROCEDURE Init
local m.myvar
text to m.myvar pretext 13 noshow
/9j/4AAQSkZJRgABAQEAYABgAAD/2wBDAAMCAgMCAgMDAwMEAwMEBQgFBQQEBQoHBwYIDAoMDAsKCwsNDhIQDQ4RDgsLEBYQERMUFRUVDA8XGBYUGBIUFRT/2wBDAQMEBAUEBQkFBQkUDQsNFBQUFBQUFBQUFBQUFBQUFBQUFBQUFBQUFBQUFBQUFBQUFBQUFBQUFBQUFBQUFBQUFBT/wAARCALuADIDASIAAhEBAxEB/8QAHwAAAQUBAQEBAQEAAAAAAAAAAAECAwQFBgcICQoL/8QAtRAAAgEDAwIEAwUFBAQAAAF9AQIDAAQRBRIhMUEGE1FhByJxFDKBkaEII0KxwRVS0fAkM2JyggkKFhcYGRolJicoKSo0NTY3ODk6Q0RFRkdISUpTVFVWV1hZWmNkZWZnaGlqc3R1dnd4eXqDhIWGh4iJipKTlJWWl5iZmqKjpKWmp6ipqrKztLW2t7i5usLDxMXGx8jJytLT1NXW19jZ2uHi4+Tl5ufo6erx8vP09fb3+Pn6/8QAHwEAAwEBAQEBAQEBAQAAAAAAAAECAwQFBgcICQoL/8QAtREAAgECBAQDBAcFBAQAAQJ3AAECAxEEBSExBhJBUQdhcRMiMoEIFEKRobHBCSMzUvAVYnLRChYkNOEl8RcYGRomJygpKjU2Nzg5OkNERUZHSElKU1RVVldYWVpjZGVmZ2hpanN0dXZ3eHl6goOEhYaHiImKkpOUlZaXmJmaoqOkpaanqKmqsrO0tba3uLm6wsPExcbHyMnK0tPU1dbX2Nna4uPk5ebn6Onq8vP09fb3+Pn6/9oADAMBAAIRAxEAPwCxp7dK6bT26Vymnt0rptPbpX8/45bn43g47HV6e3Sum09ulcpp7dK6fT26V+d45as+5wcdjq9PbpXTac3SuU09uldNp7fdr87xy3PuMHHU3w3FFMVuBRXzVj3eU+H9PbpXTae3SuU09uldLp7dK/rDHLc/nnBx2Os09uldNpzdK5TTm6V0+nt0r87xy3PucHHY6rT26V0+nN0rlNPbpXT6a3K1+eY5as+5wcTpFb5RzRUat8oor5mx7XKfDWnt0rptPbpXKae3Sul09ulf1ljlufz5g47HWac3Sum09ulcpp7dK6fT26V+dY5bn3ODjsdVp7dK6jTG5WuS09uldTpbfMK/O8ctz7jCROmVvlFFRBuBRXzVj1uU+GLBuldNpzdK5TT26V02nt0r+sMctz8Awcdjq9PbpXTae3SuV09uldLp7dK/PMctz7nBx2Os09uldTpLfMK5HT26V1ekt0r88xy3Pt8LHQ6YNwKKav3RRXzNj0+U+EtPbpXTae3SuU09uldNp7dK/rDHLc/BcHHY6vT26V0+nt0rk9PbpXT6e3SvzvHLc+5wcdjq9PbpXWaQ3ArjtPbpXYaSeBX55jlufa4de6jpVb5RRTV+6KK+asenY+DtPbkV02nt0rlNPbpXTae3Sv6vxy3PwfBx2Or09uldPp7dK5TT26V02nt0r89xy3PucHHY6vTW5FdjpLdK4nTW+Za7PST0r86xy3PsqC91HTq3yiimr90UV8zY9Gx8E6e3Sum09ulcpYN0rptObpX9Y45bn4Xg47HWae3Sul09ulcrp7dK6bT26V+eY5bn3ODjsdZpjfMtdrpDfdrh9LbpXaaO3QV+eY5bn2FFHTq3AopF+6KK+Zsdlj4EsG6V02nN0rlNPbpXTae3Sv6vxy3PxPBx2Or09uldNp7dK5XT26V0unt0r88xy3PucHHY7DST0rttJPSuF0huRXb6S3Svz3HLc+soo6dW+UUUxW+UUV81Y7LHwDp7dK6bT26Vymnt0rptPbpX9XY5bn4tg47HV6e3Sun05q5PT26V0+nt0r88x63PucHHU7PSW5Wu10g9K4bST0rttIbpX57jlufUUkdQrfKKKarfKKK+asdlj8/NPbpXTae3SuU09uldNp7dK/q7HLc/G8HHY6zT26V0+mtytcnp7dK6fTD8y1+eY5bn3ODidtpDdK7bSW6Vw+knpXbaS3Svz3HLc+jpI6Zfuiimq3yiivmrHZY/PiwbpXTae3SuV09uldNp7dK/q3HLc/IMHHY6vT26V1Glt8y1yWnt0rqdKbpX55jlufb4SJ3Gkt0rt9IbpXC6QeldvpLdK/Psctz6Ckjp1J2iimK3yj6UV81Y7LH56WDdK6bTm6Vyunt0rptPbpX9W45bn5Lg47HVae3Sur0lulcfp7dK63SG6V+eY5as+1w0dDudJbpXb6S3SuG0k9K7XSD0r8+xy3Peoo6hW+Uc0UxfuiivmrHZY/PHT26V0unt0rldPbpXTae3Sv6txy3PyjBx2Oq09uldhpJ+7XF6a3Suy0lulfneOW59pQj7qO30duFrttIbpXD6S3Su20k9K/P8ctz26SOoVvlH0oqNW+UUV81Y7bH526e3Sul09ulcrp7dK6XT26V/VmOW5+WYOOx1umtytdlo7dK4jTG+YV2mkN0r88xy3PsaCO50luldtpLcCuG0luldvpLdK/P8ctz2aSOlVvlFFIp+UUV81Y7LH50ae3Sum09ulcpp7dK6bT26V/VmOW5+ZYOOx12lnpXaaQ3SuH0luldrpDdK/PMctz62ijutJPSu10duVrh9JbpXa6S3Svz/ABy3PYpI6hW4FFMVvlFFfNWO2x+cmnt05zXTae3SuU09uldNp7dK/qvHLc/NcHHY7DSD0rttIPSuH0luldtpLdK/Psctz6qkjudJPSu20k9K4bSW6V2ukt0r8/xy3PYpI6hW+UUUxW+UUV81Y7bH5wae3Sum09ulcpp7dK6bTW5Ff1VjlufnGDidrpLdK7XSD0rh9Ib7tdro7civz7HLc+mpI7nSD0rt9JPSuG0luldtpLdK/P8AHLc9iijp1+6KKjVvlFFfNWOyx+bunt0rp9Mb5lrk9PbpXUaWeRX9VY5bn57hIncaS33a7XR25WuH0k8Cu20g8Cvz7HLc+ipI7nSW6V2uknla4bR26V2+kt8y1+f45bnsUkdKrcCikDcDmivmrHbY/NfT26V1OlN0rkdPbpXV6S3Sv6pxy3PgMLHQ7jSG6V2+knpXC6R2rt9JPSvz/HLc96kjuNIbpXb6S3SuG0k9K7bSTwK/P8ctz2KKOnX7ooqNW+UUV81Y7LH5p2Dciuu0lulcbp7dK6/ST0r+qcctz4PDx91HcaQ3Su30lulcNpDfdrtdIPyrX5/jlue7SR3WknpXbaQfu1wukHpXb6Selfn+OW57FJHTK3Aopqt8oor5qx2WPzP09uRXY6SelcVprfMK7LSG6V/VOOW58Lh1odxpDdK7fSW+Za4bR25Wu20nqK/P8ctz2qKO50luldrpLdK4fSf4a7XRz92vz/HLc9ikjqFb5RRUa/dFFfNWO2x+Z2mt8wrs9JbpXEaW3zCu00hulf1TjlufDUUdzpJ6V2uktwK4jSW6V22kNwK/P8ctz2KSO40duBXbaS3K1w2kN0rttJPSvz/HLc9ikjpg3Aopq/dFFfNWOyx+Zekt81dtpJ6Vw2knpXa6Q3Sv6pxy3Ph6SO60g/drtNJPSuI0hvmFdtpLdK/P8ctz2KSO50luldrpLdK4fSTwK7bSD92vgMctz2KSOlVvlFFMDcCivmrHbY/MzST0rtdIbpXD6SeldrpJ6V/VGOW58NSR3Wkt0rttIPArhdJbpXbaS3SvgMctz2KSO50duldvpLdK4bSW+7Xa6Qfu1+fY5bns0UdQrfKPpRUatwKK+asdlj8zNJbGK7XSW6VxGmcNj3rtNJPSv6qxy3Ph6KO40duVrt9JPSuG0luldtpDfdr8/wActz2KSO50k8Cu10g9K4bSG+7Xb6S3Svz/ABy3PYpI6dfuiimK3yiivmrHZY/M6xbbNiuy0g9K461+WYV12j9q/qfGLQ+GorY7nST0rttHPArhtJbpXbaS3Svgcctz2aKO50k9K7bST0rhtJbpXa6S3Svz/HLc9iijqFb5RRTFb5RRXzNjssfmvDxIK6nSG+7XMrw3410mknpX9T4r4T4XDrQ7jSG6V2+kt0rhtJPArtdIbpXweOW57VFHdaT2rtdIPSuG0huVrttJbkV+fY5bnsUkdQp+UUUxW+UUV81Y7LH5xFe9bukNnFY2K19J7V/UeI+FnweHXuo7nSW6V2ukN0rh9JPSu10g9K+Fxy3PcpI7nSG5Wu30k8rXDaS3Su20luBX5/jluexRR0w6CimK3yjmivmbHZY/PHbWhpZw1U9tXNO+WSv6hrbM+Awux22kt0rttJbpXDaTwBXa6QelfEY5bn0FJHdaSeBXa6Q3SuG0g8rXb6S3Svz/ABy3PYpI6dSdoopit8o+lFfNWOyx+f8AtqezGJhTNtSQDEgr+m6mzPz3CbHXaQ3K12+kt0rhdIbpXb6SelfG45bn0VJHcaQ3Su30lvu1w2knpXa6Qelfn+OW57FJHTK3AopF+6KK+Zsdtj4O20qjDD60/bQOGFf0vU2PznBnSaS3Su20hulcNpB4FdtpB6V8ljlufS0kdzpLdK7bR25WuG0g8rXbaSeRX5/jluexRR1Abgc0VEDwKK+asdlj4e20hWpdvzCjbwa/pCofm2D6Gro/BWu30lulcNpJ2sBXbaS3SvmMctz6mkjuNJbpXbaQ3Arh9JPSu10g9K/P8ctz2KSOnVvlFFNU/KKK+Zsdtj4q20bal20ba/ouofmOD6FnTfvV2ekN0rjLHibFdjpLdK+exqPraKO40huldvpDfMtcNpLdK7bSTytfn+OW57NFHTq3AoqMdBRXzVjtsfHW2jb7VJto21/QtQ/K8H0FtRtmFdbo56VycY2yKa6rSW6V4OM+E+xoLY7nSD92u10hvu1w2kN0rttJbpXwWOW57VJHUK3yiimK3yiivmrHZY+SNtJtqbbSFea/fah+U4PoRqu1h9a6TSW6Vz23pW9pLcivGxXwn2WHWiO40g9K7fST0rhdJbpXb6Q3SvhMctz3KSOnX7oopqt8oor5mx22PlbbSbal20m32r94qH5Jg+hHtrX0njArM21o6WcNj3rycR8J9rhvhO40hvu12ukH7tcNpDdK7fSW6V8Pjlue7SR06k7RRTVb5RRXzVjssfMe2jbUm2jbX7jU2PyHB9CLbVzTuJKrlansxiQV5dbZn22FOz0c9K7bST0rh9JPArtdIbgV8XjlufQUkdQv3RRUat8oor5mx22PnTb7UbeRUm2jbX7bUPxvB9CLbUluNsimjbToxtcGvMq9T7jBnVaS3Su10luBXD6S3zCu10k9K+Pxy3PpKSOnVvlFFIv3RRXzVjtseA7aNtS7aay81+y1D8XwfQj2+1A4NSbaTbXmVD7nB7m7pDdK7fSW6Vw2k9q7bST0r5bHLc+mpI6dW+UUUxW+UUV8zY7LHiO2k21LtpGWv1+ofieD6Ee2kZc4qXbSba86ofc4PoaGktjArtdJbpXEaXw+K7XST0r5vHLc+rpI6ZW+UUU1W+UUV81Y7bHjxWjbUm2jbX6xUPw7B9CLbRtqTbRt9q8+ofcYPoSWPE1dnpLcCuNtVxMK67R26V8/jUfYUUdOv3RRSK3yiivmrHZY8s20hWpdvtRtr9TqH4Zg+hFtpNtS7aNtedUPt8H0GxDEi11OkN0rmVGGFdJpLdK8TFr3T7Kh8KOoVvlFFRr90UV4Fj0TzzbSbal28ik21+lVD8EwfQj2+1JtqXbRtrzah9zg+hERxW7pDfdrG21r6TwRXj4j4WfaYdaI6dW+UUU1fuiivDPUscTto21Lto21+h1D+fsH0IttJtqXbSFa82ofc4PoR7a0NL4aqe2ren8SCvLrfCz7bDHSK3yiimK3yiivHPROZ20beRUm2jbX3lQ/n/B9CLbRtqXbSba82ofcYPoR7ansxiambeRT4PllH1rzamzPuMIbqk7RRUY6CivI5T1TJ20m2pdtJtr7mofz3g+hHt5FG2pNtG2vOqH3GD6EW2lXhx9ak20BcEV5lQ+4wm5pK3yiio1+6KK889or7aTbUu3kUlfZ1D+dMH0I9tG2pMUm2vMqH3GD6ETLzRtqXbRtrzqh9zg9yVW+UUVFuorlPcP/2Q==
endtext
strtofile(strconv(m.myvar,14),"ybg.png") &&copied in default folder
this.resize
ENDPROC
PROCEDURE spinner1.InteractiveChange
WITH thisform.container1
.BorderWidth= this.value
.parent.resize()
endwith
ENDPROC
PROCEDURE resize
WITH this.container1.grid1
.Left=.parent.BorderWidth
.Top=.parent.BorderWidth
.Width=.parent.Width-2*.parent.BorderWidth
.Height=.parent.Height-2*.parent.BorderWidth
endwith
ENDPROC
PROCEDURE Load
Close Data All
Sele * From Home(1)+"samples\data\customer" Into Cursor ycurs Readwrite
Sele ycurs
ENDPROC
PROCEDURE Destroy
clea events
ENDPROC
ENDDEFINE
*
*-- EndDefine: ygrid_border_color
*
DEFINE CLASS ycont AS container
Anchor = 15
Top = 12
Left = 10
Width = 655
Height = 265
BackStyle = 0
BorderWidth = 4
MousePointer = 15
BorderColor = RGB(255,128,64)
Name = "Container1"
ADD OBJECT grid1 AS grid WITH ;
Anchor = 0, ;
Height = 193, ;
Left = 13, ;
Top = 14, ;
Width = 543, ;
Name = "Grid1"
PROCEDURE Click
rand(-1)
this.BorderColor=RGB(255*rand(),255*rand(),255*rand())
ENDPROC
PROCEDURE grid1.Init
WITH this
.recordsource="ycurs"
.recordsourcetype=1
.deletemark=.F.
.recordmark=.F.
.highlightStyle=2
.gridlines=0
.fontsize=11
.fontname="Courier new"
.SetAll("DynamicBackColor", "IIF(MOD(RECNO(), 2) = 0, RGB(255, 255, 255), RGB(255, 255, 190) )","column")
.refresh
endwith
ENDPROC
ENDDEFINE
*
*-- EndDefine: ycont
Click on code to select [then copy] -click outside to deselect
*2*Created on friday 28 of september 2018.
*can set the grid header caption (horizontal (default) or vertical ) only with native functions.here grid.themes=.f. to benefit with headers colors....(if .f. no colors)
*(another method can build at runtime a temporarly header picture with gdiplus or gdiplusX)
*can dblclik on any header to set the header caption horizontal/vertical(can switch between these 2 states)
*Note : can try another solution if set grid.headerHeight=0 can add a container with labels adjusted to the headers and benefits of label.rotation combined with container.height...
PUBLIC oform
oform=NEWOBJECT("ygrid_headers")
oform.Show
read events
RETURN
DEFINE CLASS ygrid_headers AS form
Height = 454+5
Width = 732+10
ShowWindow = 2
ShowTips = .T.
AutoCenter = .T.
Caption = "DBLclick on any header to switch:Horizontal/Vertical header caption-resize the grid headerHeight-click the grid border to change theme."
ycl = .F.
Name = "Form1"
ADD OBJECT grid1 AS grid WITH ;
Height = 408, ;
Left = 20, ;
Top = 6, ;
Width = 706, ;
Name = "Grid1"
ADD OBJECT spinner1 AS spinner WITH ;
Anchor = 768, ;
Height = 24, ;
Left = 276, ;
ToolTipText = "Grid HeaderHeight (can adjust directly on left grid headers", ;
Top = 421+12, ;
Width = 72, ;
Value = 200, ;
Name = "Spinner1"
ADD OBJECT shape1 AS shape WITH ;
mousepointer=15,;
Name="shape1"
PROCEDURE my
*--- aevent create an array laEvents
Aevents( myArray, 0)
*--- reference the calling object
loObject = myArray[1]
thisform.ycl=iif(thisform.ycl=.F.,.T.,.F.)
WITH loObject
x=allt(.Caption)
if thisform.ycl=.T.
.Caption=""
u=""
for i=1 to len(m.x)
m.u=m.u+substr(m.x,i,1)+chr(13)
endfor
.Caption=m.u
else
.Caption=""
.Caption=strtran(m.x,chr(13),"")
endi
.fontsize=14
.fontbold=.T.
endwith
ENDPROC
PROCEDURE Load
Close Data All
Sele * From Home(1)+"samples\data\customer" Into Cursor ycurs Readwrite
Sele ycurs
Locate
ENDPROC
PROCEDURE Destroy
clea events
ENDPROC
PROCEDURE grid1.Init
WITH This
.Themes=.F. &&for headers properties ...bug in vfp9sp2
.RecordSource="ycurs"
.DeleteMark=.F.
.GridLines=2 &&0,1,2,3
.fontsize=11
.FontName="courier new"
.RowHeight=19
.allowHeaderSizing=.T. &&can resize the header height manually at runtime
.HeaderHeight=200 &&.parent.spinner1.value &&or adjust header height with mousedown on
.Anchor=15
.fontbold=.T.
.SetAll("fontsize",12,"header" )
.SetAll("fontbold",.T.,"header" )
.SetAll("forecolor",255,"header" )
rand(-1)
for j=1 to .columncount
bindevent(.columns(j).header1,"dblclick",thisform,"my")
.columns(j).header1.backcolor=rgb(255*rand(),255*rand(),255*rand())
.columns(j).header1.picture= Home(1)+"graphics\icons\traffic\trffc"+trans(9+j)+".ico"
endfor
.AutoFit()
.Refresh
endwith
local m.x,m.y
m.x=5
m.y=5
WITH thisform.shape1
.Anchor=0
.curvature=10
.Left=.parent.grid1.Left-m.x
.Top=.parent.grid1.Top-m.y
.Width=.parent.grid1.Width+2*m.x
.Height=.parent.grid1.Height+2*m.y
.zorder(1)
.backcolor=rgb(255,25,40)
.borderwidth=0
endwith
ENDPROC
PROCEDURE spinner1.UpClick
WITH thisform.grid1
.HeaderHeight=This.Value
endwith
ENDPROC
PROCEDURE spinner1.DownClick
WITH thisform.grid1
.HeaderHeight=This.Value
endwith
ENDPROC
PROCEDURE resize
local m.x,m.y
m.x=5
m.y=5
WITH thisform.shape1
.Anchor=0
.curvature=10
.Left=.parent.grid1.Left-m.x
.Top=.parent.grid1.Top-m.y
.Width=.parent.grid1.Width+2*m.x
.Height=.parent.grid1.Height+2*m.y
.zorder(1)
.backcolor=rgb(255,25,40)
.borderwidth=0
endwith
ENDPROC
PROCEDURE shape1.click
rand(-1)
This.backcolor=rgb(255*rand(),255*rand(),255*rand())
ENDPROC
ENDDEFINE
*
*-- EndDefine:ygrid_headers
grid headerHeight can be adjusted manually(mousedown) or by spinner on the form.
Click on code to select [then copy] -click outside to deselect
*3*Created on monday 1 of october 2018.
*can set the grid header multiline caption (horizontal (default) or vertical ) only with native functions(here with chr(13) strings separations)
*can dblclik on any header to set the header caption horizontal/ multiline vertical(can switch between these 2 states)
*here grid.themes=.f. to benefit with headers colors....(if .f. no colors)
PUBLIC oform
oform=NEWOBJECT("ygrid_multiline_headers")
oform.Show
read events
RETURN
DEFINE CLASS ygrid_multiline_headers AS form
Height = 454+5
Width = 732+10
ShowWindow = 2
ShowTips = .T.
AutoCenter = .T.
Caption = "DBLclick on any header to switch:Horizontal/Vertical multiline header caption-resize the grid headerHeight-click the grid border to change theme."
ycl = .F.
Name = "Form1"
ADD OBJECT grid1 AS grid WITH ;
Height = 408, ;
Left = 20, ;
Top = 6, ;
Width = 706, ;
Name = "Grid1"
ADD OBJECT spinner1 AS spinner WITH ;
Anchor = 768, ;
Height = 24, ;
Left = 276, ;
ToolTipText = "Grid HeaderHeight (can adjust directly on left grid headers", ;
Top = 421+12, ;
Width = 72, ;
Value = 200, ;
Name = "Spinner1"
ADD OBJECT shape1 AS shape WITH ;
mousepointer=15,;
Name="shape1"
PROCEDURE my
*--- aevent creates an array laEvents
Aevents( myArray, 0)
*--- reference the calling object
loObject = myArray[1]
thisform.ycl=iif(thisform.ycl=.F.,.T.,.F.)
WITH loObject
x=strtran(allt(.Caption)," ",chr(13))
if thisform.ycl=.T.
.Caption=m.x
else
.Caption=strtran(m.x,chr(13)," ")
endi
.fontsize=14
.fontbold=.T.
endwith
ENDPROC
PROCEDURE Load
Close Data All
Sele * From Home(1)+"samples\data\customer" Into Cursor ycurs Readwrite
Sele ycurs
Locate
ENDPROC
PROCEDURE Destroy
clea events
ENDPROC
PROCEDURE grid1.Init
local m.myvar
TEXT to m.myvar pretext 7 noshow
this is header1
this is header2
this is header3
this is header4
this is header5
this is header6
this is header7
this is header8
this is header10
this is header11
this is header12
ENDTEXT
WITH this
.Themes=.F. &&for headers properties ...bug in vfp9sp2
.RecordSource="ycurs"
.DeleteMark=.F.
.GridLines=2 &&0,1,2,3
.fontsize=11
.FontName="courier new"
.RowHeight=19
.allowHeaderSizing=.T. &&can resize the header height manually at runtime
.HeaderHeight=200 &&.parent.spinner1.value &&or adjust header height with mousedown on
.Anchor=15
.fontbold=.T.
.SetAll("fontsize",12,"header" )
.SetAll("fontbold",.T.,"header" )
.SetAll("forecolor",255,"header" )
for i=1 to .columncount
.columns(i).header1.Caption=allt(mline(m.myvar,i))+" "+.columns(i).header1.Caption
endfor
rand(-1)
for j=1 to .columncount
bindevent(.columns(j).header1,"dblclick",thisform,"my")
.columns(j).header1.backcolor=rgb(255*rand(),255*rand(),255*rand())
.columns(j).header1.picture= Home(1)+"graphics\icons\traffic\trffc"+trans(9+j)+".ico"
endfor
.AutoFit()
.Refresh
endwith
local m.x,m.y
m.x=5
m.y=5
WITH thisform.shape1
.Anchor=0
.curvature=10
.Left=.parent.grid1.Left-m.x
.Top=.parent.grid1.Top-m.y
.Width=.parent.grid1.Width+2*m.x
.Height=.parent.grid1.Height+2*m.y
.zorder(1)
.backcolor=rgb(255,25,40)
.borderwidth=0
endwith
ENDPROC
PROCEDURE spinner1.UpClick
WITH thisform.grid1
.HeaderHeight=this.Value
endwith
ENDPROC
PROCEDURE spinner1.DownClick
WITH thisform.grid1
.HeaderHeight=this.Value
endwith
ENDPROC
PROCEDURE resize
local m.x,m.y
m.x=5
m.y=5
WITH thisform.shape1
.Anchor=0
.curvature=10
.Left=.parent.grid1.Left-m.x
.Top=.parent.grid1.Top-m.y
.Width=.parent.grid1.Width+2*m.x
.Height=.parent.grid1.Height+2*m.y
.zorder(1)
.backcolor=rgb(255,25,40)
.borderwidth=0
endwith
ENDPROC
PROCEDURE shape1.click
rand(-1)
this.backcolor=rgb(255*rand(),255*rand(),255*rand())
ENDPROC
ENDDEFINE
*
*-- EndDefine:ygrid_multiline_headers
A sdimple way to build multiline header in grid.
Click on code to select [then copy] -click outside to deselect
*4*created on tuesday 2 of October 2018
*the code draws a simple colored border with the vfp function Box()
*this is a solution to simulate a grid border (native border is vfp system window border and don't have any property to change borderWidth,Bordercolor).
PUBLIC oform
oform1=NEWOBJECT("ygrid_border_color")
oform1.Show
read events
RETURN
*
DEFINE CLASS ygrid_border_color AS form
Height = 296+40
Width = 700
ShowWindow = 2
AutoCenter = .T.
showtips=.T.
scalemode=3
Caption = "draw a simple border on the grid.can resize the form/grid"
Name = "Form1"
ADD OBJECT grid1 AS grid WITH ;
Anchor = 15, ;
Height =310, ;
Left =10, ;
Top = 10, ;
Width = 670, ;
Name = "Grid1"
PROCEDURE grid1.Init
WITH this
.recordsource="ycurs"
.recordsourcetype=1
.deletemark=.F.
.recordmark=.F.
.highlightStyle=2
.gridlines=0
.fontsize=11
.fontname="Courier new"
.SetAll("DynamicBackColor", "IIF(MOD(RECNO(), 2) = 0, RGB(255, 255, 255), RGB(255, 255, 190) )","column")
.refresh
endwith
ENDPROC
PROCEDURE resize &&draw a simple rectangle bounding the grid with any choosen color
thisform.cls
thisform.forecolor=rgb(0,0,64) &&&getcolor()
thisform.box(thisform.grid1.Left-1,thisform.grid1.Top-1,thisform.grid1.Left+2+thisform.grid1.Width,thisform.grid1.Top+2+thisform.grid1.Height)
ENDPROC
PROCEDURE Load
Close Data All
Sele * From Home(1)+"samples\data\customer" Into Cursor ycurs Readwrite
Sele ycurs
ENDPROC
PROCEDURE Destroy
clea events
ENDPROC
ENDDEFINE
*
*-- EndDefine: ygrid_border_color
Click on code to select [then copy] -click outside to deselect
*5* created on tuesday 2 of october 2018
*this code can create a dynamic border on any vfp control on a form
*it creates a shape on MouseEnter event of any control and destry it at mouseLeave event.
*the shape bordercolor and the borderwidth can be modified in code
PUBLIC oform
oform=NEWOBJECT("ycontrols_borders")
oform.Show
RETURN
DEFINE CLASS ycontrols_borders AS form
Height = 423
Width = 1040
ShowWindow = 2
AutoCenter = .T.
maxbutton=.f.
borderstyle=0
Caption = "Drawing a border on any vfp control with a shape on mouseenter event-destroy it on MouseLeave event."
Name = "Form1"
ADD OBJECT text1 AS textbox WITH ;
Value = "this is a textbox", ;
Height = 23, ;
Left = 36, ;
Top = 24, ;
Width = 100, ;
Name = "Text1"
ADD OBJECT label1 AS label WITH ;
Caption = "Label1", ;
Height = 17, ;
Left = 168, ;
Top = 24, ;
Width = 144, ;
Name = "Label1"
ADD OBJECT edit1 AS editbox WITH ;
Height = 120, ;
Left = 36, ;
Top = 60, ;
Width = 100, ;
Value = "This is an editbox", ;
Name = "Edit1"
ADD OBJECT command1 AS commandbutton WITH ;
Top = 24, ;
Left = 360, ;
Height = 48, ;
Width = 84, ;
Caption = "Command1", ;
Name = "Command1"
ADD OBJECT combo1 AS combobox WITH ;
Height = 24, ;
Left = 180, ;
Top = 84, ;
Width = 100, ;
Name = "Combo1"
ADD OBJECT grid1 AS grid WITH ;
Height = 200, ;
Left = 240, ;
Top = 192, ;
Width = 480, ;
Name = "Grid1"
ADD OBJECT image1 AS image WITH ;
Picture = home(1)+"graphics\icons\misc\misc15.ico", ;
Stretch = 2, ;
BackStyle = 0, ;
Height = 96, ;
Left = 540, ;
Top = 12, ;
Width = 121, ;
Name = "Image1"
ADD OBJECT pageframe1 AS pageframe WITH ;
ErasePage = .T., ;
PageCount = 2, ;
Top = 12, ;
Left = 732, ;
Width = 265, ;
Height = 169, ;
Name = "Pageframe1", ;
Page1.Caption = "Page1", ;
Page1.Name = "Page1", ;
Page2.Caption = "Page2", ;
Page2.Name = "Page2"
ADD OBJECT container1 AS container WITH ;
Top = 204, ;
Left = 768, ;
Width = 169, ;
Height = 97, ;
Name = "Container1"
ADD OBJECT list1 AS listbox WITH ;
Height = 133, ;
Left = 36, ;
Top = 204, ;
Width = 109, ;
Name = "List1"
PROCEDURE my1
LPARAMETERS nButton, nShift, nXCoord, nYCoord
*--- aevent creates an array laEvents
Aevents( myArray, 0)
*--- reference the calling object
loObject = myArray[1]
WITH thisform
.addObject("shape1","shape")
WITH .shape1 &&can modify the shape border width
.Left=loObject.Left-1
.Top=loObject.Top-1
.Width=loObject.Width+2
.Height=loObject.Height+2
.zorder(1)
.bordercolor=255
.borderwidth=1
.visible=.T.
endwith
endwith
ENDPROC
PROCEDURE my2
LPARAMETERS nButton, nShift, nXCoord, nYCoord
*--- aevent creates an array laEvents
Aevents( myArray, 0)
*--- reference the calling object
loObject = myArray[1]
thisform.removeObject("shape1")
ENDPROC
PROCEDURE Init
WITH thisform
for i=1 to .controlcount
bindevent(.controls(i),"mouseEnter",thisform,"my1")
bindevent(.controls(i),"mouseLeave",thisform,"my2")
endfor
endwith
ENDPROC
PROCEDURE Destroy
clea events
ENDPROC
PROCEDURE grid1.Init
Sele * From home(1)+"samples\data\customer" Into Cursor ycurs Readwrite
WITH this
.recordsource="ycurs"
.recordsourcetype=1
.deletemark=.F.
.recordmark=.F.
.highlightStyle=2
.gridlines=0
.fontsize=11
.fontname="Courier new"
.SetAll("DynamicBackColor", "IIF(MOD(RECNO(), 2) = 0, RGB(255, 255, 255), RGB(0, 255, 190) )","column")
.refresh
endwith
ENDPROC
ENDDEFINE
*
*-- EndDefine: ycontrols_borders
Click on code to select [then copy] -click outside to deselect
*6*created on wednesday 3 of October 2018
*the code draws simple colored borders with the vfp functions Box() and lines()
*this is a solution to simulate a grid border (native border is vfp system window border and don't have any property to change borderWidth,Bordercolor).
*a dummy textbox is added to the form to switch between colors of active grid/inactive and when(),valid(à event to play with grid focusings.
*active/inactive olors can be selected with 2 shapes bottom the form.
PUBLIC oform
oform1=NEWOBJECT("ygrid_border_color")
oform1.Show
read events
RETURN
*
DEFINE CLASS ygrid_border_color AS form
Height =365
Width = 700
ShowWindow = 0 && works for 2 also
AutoCenter = .T.
showtips=.T.
scalemode=3
ycl=0
Caption = "draw a simple border on the grid.can resize the form/grid"
Name = "Form1"
ADD OBJECT grid1 AS grid WITH ;
themes=.T.,;
Anchor = 15, ;
AllowHeaderSizing=.F.,;
fontsize=12,;
fontbold=.T.,;
Height =300, ;
Left =10, ;
Top = 10, ;
Width = 670, ;
Name = "Grid1"
ADD OBJECT shp1 AS shape WITH ;
Anchor =768,;
Left=15,;
Top=338,;
Width=13,;
Height=13,;
curvature=99,;
backcolor=rgb(192,192,192),;
mousepointer=15,;
tooltiptext="Inactive border color",;
Name="shp1"
ADD OBJECT shp2 AS shape WITH ;
Anchor =768,;
Left=34,;
Top=338,;
Width=13,;
Height=13,;
curvature=99,;
backcolor=255,;
mousepointer=15,;
tooltiptext="active border color",;
Name="shp2"
ADD OBJECT text1 AS textbox WITH ;
Top =335, ;
Left = 312, ;
Height = 27, ;
Width=50 ,;
Anchor = 768, ;
tooltiptext="switch grid border colors active/inactive"
Name = "text1"
PROCEDURE grid1.Init
WITH this
.recordsource="ycurs"
.recordsourcetype=1
.deletemark=.F.
.recordmark=.F.
.highlightStyle=2
.gridlines=0 &&3
.fontsize=11
.fontname="Courier new"
.headerHeight=27
*.scrollbars=3
.SetAll("DynamicBackColor", "IIF(MOD(RECNO(), 2) = 0, RGB(255, 255, 255), RGB(255, 255, 190) )","column")
.refresh
endwith
ENDPROC
PROCEDURE shp1.click
local m.x
m.x=getcolor()
if !m.x=-1
this.backcolor=m.x
endi
ENDPROC
PROCEDURE shp2.click
local m.x
m.x=getcolor()
if !m.x=-1
this.backcolor=m.x
endi
ENDPROC
PROCEDURE grid1.when
thisform.ycl=1
thisform.resize()
ENDPROC
PROCEDURE grid1.valid
thisform.ycl=2
thisform.resize()
ENDPROC
PROCEDURE grid1.mouseWheel
LPARAMETERS nDirection, nShift, nXCoord, nYCoord
*if ndirection>0
thisform.grid1.refresh && avoid persistent drawing
*endi
ENDPROC
PROCEDURE resize &&draw a simple rectangle bounding the grid with any choosen color and headers bottom border
LPARAMETERS nButton, nShift, nXCoord, nYCoord
thisform.cls
thisform.box(thisform.grid1.Left-1,thisform.grid1.Top-1,thisform.grid1.Left+2+thisform.grid1.Width,thisform.grid1.Top+2+thisform.grid1.Height)
WITH thisform
.drawWidth=2
try
.AddObject('Line1','Line')
catch
endtry
WITH .line1
.Left=thisform.grid1.Left+2
.Top=thisform.grid1.Top+thisform.grid1.headerHeight
.Width=thisform.grid1.Width-4-15
.borderWidth=thisform.drawWidth
.Height=1
.bordercolor=iif(thisform.ycl=1,thisform.shp2.backcolor,thisform.shp1.backcolor)
.zorder(0)
.visible=.T.
.zorder(0)
.Top=.Top
endwith
thisform.cls
thisform.forecolor=iif(thisform.ycl=1,thisform.shp2.backcolor,thisform.shp1.backcolor)
thisform.box(thisform.grid1.Left-1,thisform.grid1.Top-1,thisform.grid1.Left+2+thisform.grid1.Width,thisform.grid1.Top+2+thisform.grid1.Height)
.refresh
endwith
ENDPROC
PROCEDURE Load
Close Data All
Sele * From Home(1)+"samples\data\customer" Into Cursor ycurs Readwrite
Sele ycurs
ENDPROC
PROCEDURE Destroy
clea events
ENDPROC
ENDDEFINE
*
*-- EndDefine: ygrid_border_color
Click on code to select [then copy] -click outside to deselect
*7* created on wednesday 3 of october 2018
*using the property grid.themes=.f. can colorize the grid.headers(that is not possible with grid.themes=.t.)-here headers are colorized randomly(can make option for fixed colors or one color....)
*adding a dummy textbox can switch active/inactive grid (here random colors in active grid.header and gray for inactive)
*this draws also a outer border around the grid.
PUBLIC oform
oform=NEWOBJECT("ygrid_colorized_headers")
oform.Show
RETURN
*
DEFINE CLASS ygrid_colorized_headers AS form
Height = 563
Width = 1136
ShowWindow = 2
ShowTips = .T.
AutoCenter = .T.
Caption = "Form1"
Name = "Form1"
ADD OBJECT grid1 AS grid WITH ;
Height = 499, ;
Left = 11, ;
ScrollBars = 3, ;
Top = 12, ;
Width = 1109, ;
Name = "Grid1"
ADD OBJECT text1 AS textbox WITH ;
Anchor = 768, ;
Height = 25, ;
Left = 588, ;
ToolTipText = "Dummy textbox to switch active/inactive colors", ;
Top = 525+5, ;
Width = 84, ;
Name = "Text1"
PROCEDURE Activate
thisform.cls
thisform.forecolor=255
thisform.drawWidth=2
thisform.box(thisform.grid1.Left-1,thisform.grid1.Top-1,thisform.grid1.Left+3+thisform.grid1.Width+15,thisform.grid1.Top+3+thisform.grid1.Height+15)
ENDPROC
PROCEDURE Resize
thisform.grid1.when()
ENDPROC
PROCEDURE Destroy
clea events
ENDPROC
PROCEDURE grid1.Valid
WITH thisform.grid1
for i=1 to .columncount
.columns(i).header1.backcolor=rgb(225,225,225)
endfor
.refresh
endwith
thisform.cls
thisform.forecolor=rgb(192,192,192)
thisform.drawWidth=2
thisform.box(thisform.grid1.Left-1,thisform.grid1.Top-1,thisform.grid1.Left+3+thisform.grid1.Width,thisform.grid1.Top+3+thisform.grid1.Height)
ENDPROC
PROCEDURE grid1.when
local m.x
WITH thisform.grid1
for i=1 to .columncount
m.x=rgb(255*rand(),255*rand(),255*rand())
if m.x=0
m.x=rgb(255*rand(),255*rand(),255*rand())
endi
.columns(i).header1.backcolor=m.x
endfor
.refresh
endwith
thisform.cls
thisform.forecolor=255
thisform.drawWidth=2
thisform.box(thisform.grid1.Left-1,thisform.grid1.Top-1,thisform.grid1.Left+3+thisform.grid1.Width,thisform.grid1.Top+3+thisform.grid1.Height)
ENDPROC
PROCEDURE grid1.Init
sele * from home(1)+"samples\data\customer" into cursor ycurs readWrite
rand(-1)
WITH this
.themes=.F.
.Anchor=15
.recordsource="ycurs"
.recordsourcetype=1
.headerHeight=30
.deletemark=.F.
.gridlines=2
.autofit()
for i=1 to .columncount
.columns(i).header1.backcolor=rgb(255*rand(),255*rand(),255*rand())
.columns(i).header1.fontbold=.T.
.columns(i).header1.fontsize=12
bindevent(.columns(i).header1,"mouseEnter",thisform,"my")
bindevent(.columns(i).header1,"mouseLeave",thisform,"my1")
endfor
.highlightStyle=2
.fontname="Courier new"
.SetAll("DynamicBackColor", "IIF(MOD(RECNO(), 2) = 0, RGB(255, 255, 255), RGB(255, 255, 190) )","column")
.refresh
endwith
ENDPROC
PROCEDURE my
LPARAMETERS nButton, nShift, nXCoord, nYCoord
*--- aevent creates an array laEvents
Aevents( myArray, 0)
*--- reference the calling object
loObject = myArray[1]
loObject.mousepointer=15
loObject.fontunderline=.T.
ENDPROC
PROCEDURE my1
LPARAMETERS nButton, nShift, nXCoord, nYCoord
*--- aevent creates an array laEvents
Aevents( myArray, 0)
*--- reference the calling object
loObject = myArray[1]
loObject.mousepointer=0
loObject.fontunderline=.F.
ENDPROC
ENDDEFINE
*
*-- EndDefine: ygrid_colorized_headers
|
|
Yousfi Benameur |
Important:All Codes above are tested on VFP9SP2 & windows 10 pro 64 bits version 1803 . Navigator: firefox 62.0.2 64 bits - screen:32 pouces.