A glass form as exiting windows effect
This code build a transparent top level form (mandatory .i set opacity=210 for best contrast) and populate with some vfp controls.when releasing the form the screen becomes entirely full of black transparent and a messagebox raises to ask if you want to quit....as windows do for asking open as administrator....(see demo photos below).
This uses APIs only.
Infortunatly i cannot send a zip in this blog, so i present the complet prg code below.
*build a black transparent form covering all the screen as windows do...
*this can be also used to make a locking screen unlocked with a password for ex...
*can cutomize the transpareny (0-255 but 210 is the best for black,can also change color)
*All controls are hidden if the exiting process is started, redrawing if no exiting.
*In next i present a code to make a background picture to a vfp grid with an artifice.
*Pressing Esc at any time releases the form.
*Begin Code
Publi yform
yform=Newobject("yglass")
yform.Show
Read Events
Return
*
Define Class yglass As Form
BorderStyle = 3
Height = 368
Width = 815
ShowWindow = 2
AutoCenter = .T.
Caption = ""
BackColor = Rgb(0,0,0)
Name = "Form1"
Add Object olecontrol1 As OleControl With ;
oleclass="MSComCtl2.MonthView.2", ;
Top = 12, ;
Left = 48, ;
Height = 193, ;
Width = 217, ;
Name = "Olecontrol1"
Add Object grid1 As Grid With ;
Anchor=15,;
Height = 336, ;
Left = 288, ;
Top = 12, ;
Width = 516, ;
Name = "Grid1"
Add Object olecontrol2 As OleControl With ;
oleclass="MSComCtl2.DTPicker.2", ;
Top = 252, ;
Left = 60, ;
Height = 49, ;
Width = 193, ;
Name = "Olecontrol2"
Add Object asup As Checkbox With ;
Top = 324, ;
Left = 120, ;
Height = 18, ;
Width = 103, ;
FontBold = .T., ;
FontSize = 10, ;
AutoSize = .T., ;
Alignment = 0, ;
BackStyle = 0, ;
Caption = "Checked grid", ;
ForeColor = Rgb(255,0,0), ;
Name = "asup"
Procedure asup.InteractiveChange
Thisform.ybuild()
Endproc
Procedure QueryUnload
With Thisform
For i=1 To .ControlCount
Try
.Controls(i).Visible=.F.
Catch
Endtry
Endfor
Local xleft,xtop,xwidth,xheight
m.xleft=.Left
m.xtop=.Top
m.xwidth=.Width
m.xheight=.Height
.Left=-20
.Top=-40
.Width =Sysmetric(1)+20
.Height=Sysmetric(2)+40
If ! Messagebox("Want really to quit ?",4+64,'')=6
Nodefault
.Left=m.xleft
.Top=m.xtop
.Width=m.xwidth
.Height=m.xheight
For i=1 To .ControlCount
Try
.Controls(i).Visible=.T.
Catch
Endtry
Endfor
Endi
Endwith
Endproc
Procedure Init
Try
_Screen.WindowState=1
Catch
Endtry
With Thisform.olecontrol1
.MonthBackcolor=65280
.BackColor=4194432
Endwith
With Thisform.olecontrol2
.CalendarTrailingForecolor=4227327
.CalendarbackColor=65535
.Font.bold=.T.
Endwith
Thisform.ybuild()
_Sol_SetWindowLong(Thisform.HWnd, -20, 0x00080000)
_Sol_SetLayeredWindowAttributes(Thisform.HWnd, 0,210, 2)
Endproc
Procedure ybuild
With Thisform.grid1
.RecordSource=""
.RecordSourceType=1
.GridLines=0
.DeleteMark=.F.
.HeaderHeight=22
.SetAll("DynamicBackColor", "IIF(MOD(RECNO( ), 2)=0, RGB(255,255,255) , RGB(167,255,210))", "Column")
If Thisform.asup.Value=1
Sele .F. As ycheck,* From Home(1)+"samples\data\customer" Into Cursor ycurs Readwrite
.RecordSource="ycurs"
With .column1
.AddObject("check1", "checkbox")
.check1.Caption=""
.CurrentControl="check1"
.ControlSource="ycurs.ycheck"
.Sparse=.F.
.Visible=.T.
Endwith
.SetAll("DynamicBackColor", "IIF(MOD(RECNO( ), 2)=0, RGB(255,255,255) , RGB(197,135,200))", "Column")
Else
Sele * From Home(1)+"samples\data\customer" Into Cursor ycurs Readwrite
.RecordSource="ycurs"
With .column1
Try
.RemoveObject("check1")
Catch
Endtry
.CurrentControl="text1"
Endwith
.SetAll("DynamicBackColor", "IIF(MOD(RECNO( ), 2)=0, RGB(255,255,255) , RGB(167,205,240))", "Column")
Endi
Locate
.SetFocus
Endwith
Endproc
Procedure Load
Declare SetWindowLong In Win32Api As _Sol_SetWindowLong Integer, Integer, Integer
Declare SetLayeredWindowAttributes In Win32Api As ;
_Sol_SetLayeredWindowAttributes Integer, String, Integer, Integer
Sele .F. As ycheck,* From Home(1)+"samples\data\customer" Into Cursor ycurs Readwrite
Sele ycurs
Locate
Endproc
Procedure Destroy
Clea Events
Endproc
Enddefine
*End Code
can customize any color-see the 3rd image below
*this another code uses the native vfp shape properties to make a filter transparent mask on the *form .With some tweaks can have the same effect as windows exciting effect.
*Begin code
Publi yform
yform=Newobject("ylightbox")
yform.Show
Read Events
Return
Define Class ylightbox As Form
Height = 422
Width = 610
ShowWindow = 2
ShowTips = .T.
AutoCenter = .T.
Picture = ""
Caption = "mutli color lightbox on vfp form"
Name = "Form1"
Add Object shape1 As Shape With ;
Top = 0, ;
Left = 0, ;
Height = 423, ;
Width = 611, ;
Anchor = 15, ;
DrawMode = 9, ;
Visible = .F., ;
SpecialEffect = 0, ;
BackColor = Rgb(45,45,45), ;
Name = "Shape1"
Add Object command1 As CommandButton With ;
Top = 393, ;
Left = 283, ;
Height = 27, ;
Width = 84, ;
FontSize = 11, ;
Anchor = 768, ;
Caption = "Click me !", ;
MousePointer = 15, ;
ForeColor = Rgb(255,0,0), ;
BackColor = Rgb(0,255,0), ;
Name = "Command1"
Add Object grid1 As Grid With ;
Anchor = 15, ;
DeleteMark = .F., ;
GridLines = 0, ;
Height = 294, ;
Left = 34, ;
Top = 81, ;
Width = 539, ;
Name = "Grid1"
Add Object image1 As Image With ;
Picture = Home(1)+"graphics\icons\elements\earth.ico", ;
Stretch = 2, ;
BackStyle = 0, ;
Height = 62, ;
Left = 481, ;
Top = 5, ;
Width = 69, ;
Name = "Image1"
Add Object optiongroup1 As OptionGroup With ;
AutoSize = .T., ;
ButtonCount = 5, ;
Anchor = 768, ;
BackStyle = 0, ;
BorderStyle = 0, ;
Value = 1, ;
Height = 28, ;
Left = 16, ;
MousePointer = 15, ;
Top = 11, ;
Width = 110, ;
BackColor = Rgb(45,45,45), ;
ToolTipText = "Change lightbox colors here", ;
Name = "Optiongroup1", ;
Option1.Caption = "", ;
Option1.Value = 1, ;
Option1.Height = 17, ;
Option1.Left = 5, ;
Option1.Top = 5, ;
Option1.Width = 18, ;
Option1.AutoSize = .T., ;
Option1.Name = "Option1", ;
Option2.Caption = "", ;
Option2.Height = 17, ;
Option2.Left = 26, ;
Option2.Top = 6, ;
Option2.Width = 18, ;
Option2.AutoSize = .T., ;
Option2.Name = "Option2", ;
Option3.Caption = "", ;
Option3.Height = 17, ;
Option3.Left = 47, ;
Option3.Top = 6, ;
Option3.Width = 18, ;
Option3.AutoSize = .T., ;
Option3.Name = "Option3", ;
Option4.Caption = "", ;
Option4.Height = 17, ;
Option4.Left = 67, ;
Option4.Top = 6, ;
Option4.Width = 18, ;
Option4.AutoSize = .T., ;
Option4.Name = "Option4", ;
Option5.Caption = "", ;
Option5.Height = 17, ;
Option5.Left = 87, ;
Option5.Top = 6, ;
Option5.Width = 18, ;
Option5.AutoSize = .T., ;
Option5.Name = "Option5"
Add Object label1 As Label With ;
AutoSize = .T., ;
FontSize = 10, ;
BackStyle = 0, ;
Caption = "Lightbox colors", ;
Height = 18, ;
Left = 30, ;
Top = 54, ;
Width = 90, ;
ForeColor = Rgb(255,0,0), ;
Name = "Label1"
Add Object shape2 As Shape With ;
Top = 15, ;
Left = 138, ;
Height = 25, ;
Width = 33, ;
Anchor = 768, ;
BorderWidth = 2, ;
Curvature = 15, ;
BackColor = Rgb(45,45,45), ;
BorderColor = Rgb(255,0,0), ;
Name = "Shape2"
Procedure Init
Sele ycurs
Locate
With This.grid1
.RecordSource="ycurs"
.AutoFit()
.SetAll("DynamicBackColor", "IIF(MOD(RECNO( ), 2)=0, RGB(255,255,255) , RGB(197,135,200))", "Column")
Endwith
Endproc
Procedure Load
Close Data All
Sele * From Home(1)+"samples\data\customer" Into Cursor ycurs Readwrite
Endproc
Procedure Destroy
Clea Events
Endproc
Procedure command1.Click
With Thisform.shape1
.BackColor=Thisform.shape2.BackColor
.ZOrder(0)
.Visible=.T.
Messagebox("Do something from here !",0x1000,"")
.Visible=.F.
Endwith
Endproc
Procedure optiongroup1.InteractiveChange
Do Case
Case This.Value=1
Thisform.shape2.BackColor=Rgb(45,45,45)
Case This.Value=2
Thisform.shape2.BackColor=Rgb(74,0,0)
Case This.Value=3
Thisform.shape2.BackColor=Rgb(0,85,0)
Case This.Value=4
Thisform.shape2.BackColor=Rgb(0,0,180)
Case This.Value=5
Local xcolor
xcolor=Getcolor()
If xcolor#-1
Thisform.shape2.BackColor=m.xcolor
Endi
Endcase
Endproc
Procedure Destroy
Clea Events
Endproc
Enddefine
*End Code
*In same register,This is another code producing a transparent form with many capabilities.
*F12 to see the help and what keypress buttons are coded to see effects
*A top level form with transparency.All param coded are adjustable by keyboard (F12 for help)
*ESC to release the from (or ALT+F4)
*can add a password to lock the computer screen by any keypress button event(but disable ALT+f4 shortkey : nodefault in form.keypress of ALT+F4).
*Begin Code
Publi yform,m.yrep, m.xleft,m.xtop,m.xwidth,m.xheight
m.yrep=Addbs(Justpath(Sys(16,1)))
Set Defa To (yrep)
Set Safe Off
Local m.myvar
TEXT to m.myvar noshow
#DEFINE LWA_COLORKEY 1
#DEFINE LWA_ALPHA 2
#DEFINE GWL_EXSTYLE -20
#DEFINE WS_EX_LAYERED 0x80000
ENDTEXT
Strtofile(m.myvar, m.yrep+"yconst.h")
yform=Newobject("yglass")
yform.Show
Read Events
Return
*
#INCLUDE "yconst.h" &&windows defined constants created before in the sourcee folder.
Define Class yglass As Form
Height = 611
Width = 952
ShowWindow = 2
AutoCenter = .T.
Caption = ""
KeyPreview = .T.
TitleBar = 0
AlwaysOnTop = .T.
BackColor =0 && Rgb(128,0,64)...
yalpha = 170 &&0-255 but best results over 100 (opacity settings)
nleft = .F.
ntop = .F.
ldown = .F.
ytour=0
yfs=.F.
xpict=""
Name = "Form1"
Add Object shape1 As Shape With ;
Top = 24, ;
Left = 648, ;
Height = 121, ;
Width = 121, ;
BorderWidth = 8, ;
Curvature = 30, ;
MousePointer = 15, ;
Visible = .F., ;
BackColor = Rgb(0,255,0), ;
BorderColor = Rgb(0,0,255), ;
Name = "Shape1"
Add Object image1 As Image With ;
Anchor = 15, ;
Picture = "cheval.jpg", ;
Stretch = 2, ;
Height = 288, ;
Left = 156, ;
Top = 72, ;
Width = 468, ;
Name = "Image1"
Add Object timer1 As Timer With ;
Top = 48, ;
Left = 852, ;
Height = 23, ;
Width = 23, ;
Enabled = .F., ;
Interval = 3500, ;
Name = "Timer1"
Procedure yhole
Thisform.shape1.BorderColor=Rgb(255*Rand(),255*Rand(),255*Rand())
Thisform.shape1.Visible=.T.
Thisform.shape1.ZOrder(0)
= SetLayeredWindowAttributes(Thisform.HWnd, Thisform.shape1.BackColor,Thisform.yalpha,LWA_COLORKEY+LWA_ALPHA)
Endproc
Procedure Destroy
Set Safe On
Clea Dlls
Clea Events
Endproc
Procedure DblClick
Thisform.Release
Endproc
Procedure Activate
If Thisform.ytour=0
Keyboard "{F12}" &&help one once.
Thisform.ytour=Thisform.ytour+1
Endi
Endproc
Procedure MouseDown
Lparameters nButton, nShift, nXCoord, nYCoord
If !Thisform.WindowState=2
lnHandle = Thisform.HWnd &&getFocus()
param1 = 274
param2 = 0xF012
Declare Integer ReleaseCapture In WIN32API
Declare Integer SendMessage In WIN32API Integer, Integer, Integer, Integer
bb=ReleaseCapture()
bb=SendMessage(lnHandle, param1, param2,0)
Endi
Endproc
Procedure Load
Declare Integer GetWindowLong In user32;
INTEGER HWnd, Integer nIndex
Declare Integer SetWindowLong In user32;
INTEGER HWnd, Integer nIndex, Integer dwNewLong
Declare Integer SetLayeredWindowAttributes In user32;
INTEGER HWnd, Integer crKey,;
SHORT bAlpha, Integer dwFlags
Create Cursor ycurs(yimage c(200))
Endproc
Procedure Init
Local m.xpict
Thisform.xpict=Getpict()
Thisform.image1.Picture=Thisform.xpict
set defa to (yrep)
Try &&to see well the effect
_Screen.WindowState=1
Catch
Endtry
Local nExStyle, nRgb, nAlpha, nFlags
nExStyle = GetWindowLong(Thisform.HWnd, GWL_EXSTYLE)
nExStyle = Bitor(nExStyle, WS_EX_LAYERED)
= SetWindowLong(Thisform.HWnd, GWL_EXSTYLE, nExStyle)
= SetLayeredWindowAttributes(Thisform.HWnd, Thisform.BackColor,Thisform.yalpha,LWA_ALPHA)
Endproc
Procedure KeyPress
Lparameters nKeyCode, nShiftAltCtrl
If nKeyCode=27
Thisform.Release
Endi
If nKeyCode=109 Or nKeyCode=77 &&m or M
Do Case
Case Thisform.WindowState=2
Thisform.WindowState=0
Case Thisform.WindowState=0
Thisform.WindowState=2
Endcase
Endi
If nKeyCode=134 &&h F12 HELP
Local m.myvar
TEXT to m.myvar noshow
This is a similar glass filter with a top level form alwaysontop.
The alpha effect is applied and can be customized:0-255 values.make a rightclick.
The color can also be customized(press c/C to set color).
Press m/M to maximize the form overlapping the screen.This can lock your screen
Press m/M to unlock fullscreen and restaure .
Press h to make the circle shape visible.mousedown to move the circle shape.Can drag
to a desktop icon and click to execute it.
Press h/H to make the circle shape visible or invisible.
Press i/I to raise or hide (if visible) the background image .
Press d/D to play a diaporama from any images folder (CTRL+D to stop it).
Press f/F to make fullscreen on/off
Rightclick on shape border to set its curvature (0-99).
the form is movable by mouse (only if not fullscreen).
Press F12 to summary help.
ESC or dblClick to release the form.
ENDTEXT
Messagebox(m.myvar,0+32+4096,"summary help")
Endi
If nKeyCode= 99 Or nKeyCode=67 &&C change background color (c or C)
#Define LWA_COLORKEY 1
#Define LWA_ALPHA 2
Thisform.BackColor=Getcolor()
= SetLayeredWindowAttributes(Thisform.HWnd, Thisform.BackColor,Thisform.yalpha,LWA_ALPHA)
Endi
If nKeyCode= 104 Or nKeyCode=72 &&h or H hole
Do Case
Case Thisform.shape1.Visible=.F.
Thisform.yhole()
Case Thisform.shape1.Visible=.T.
Thisform.shape1.Visible=.F.
Endcase
Endi
If nKeyCode=105 Or nKeyCode=73 &&i image visible or no
Thisform.image1.Visible=!Thisform.image1.Visible
Endi
If nKeyCode=102 Or nKeyCode= 70 &&f/F fullscreen on/off
With Thisform
Do Case
Case .yfs=.F.
.yfs=.T.
m.xleft=.Left
m.xtop=.Top
m.xwidth=.Width
m.xheight=.Height
.Top=-40
.Left=-20
.Width= Sysmetric(1)+20
.Height=Sysmetric(2)+40
Case .yfs=.T.
.yfs=.F.
.Left=m.xleft
.Top=m.xtop
.Width=m.xwidth
.Height=m.xheight
Endcase
Endwith
Endi
If nKeyCode=100 Or nKeyCode=68 &&d/D diaporam from any images folder
Try
Sele ycurs
Zap
Catch
Create Cursor ycurs(yimage c(200))
Endtry
Local m.yrep0,gnbre
yrep0=Getdir()
If Empty(m.yrep0)
Return .F.
Endi
m.yrep0=Addbs(m.yrep0)
gnbre=Adir(gabase,m.yrep0+"*.*")
Set Defa To (yrep0)
For i=1 To gnbre
If Inlist( Lower( Justext(gabase(i,1) )) ,"jpg","bmp","gif","png")
Insert Into ycurs Values (Allt(m.yrep0+gabase(i,1)))
Endi
Endfor
Sele ycurs
If Reccount()=0
Return .F.
Endi
Locate
Thisform.image1.Picture=yimage
Thisform.image1.Visible=.T.
Thisform.timer1.Enabled=.T.
Endi
Endproc
Procedure RightClick
#Define LWA_COLORKEY 1
#Define LWA_ALPHA 2
Thisform.yalpha=Int(Val(Inputbox("Alpha 0-255","",Trans(Thisform.yalpha))))
If Empty(Thisform.yalpha)
Thisform.yalpha=170
Endi
= SetLayeredWindowAttributes(Thisform.HWnd, Thisform.BackColor,Thisform.yalpha,LWA_ALPHA)
Endproc
Procedure shape1.MouseUp
Lparameters nButton, nShift, nXCoord, nYCoord
Thisform.ldown = .F.
Endproc
Procedure shape1.MouseMove
Lparameters nButton, nShift, nXCoord, nYCoord
If nButton = 1 And Thisform.ldown
This.Move(nXCoord - Thisform.nleft, nYCoord - Thisform.ntop)
Endif
Endproc
Procedure shape1.MouseDown
Lparameters nButton, nShift, nXCoord, nYCoord
If !Thisform.ldown
Thisform.ldown = .T.
Thisform.nleft = nXCoord - This.Left
Thisform.ntop = nYCoord - This.Top
Endif
Endproc
Procedure shape1.RightClick
Local m.xcurv
m.xcurv=Inputbox("shape Curvature:0-99","",Trans(This.Curvature))
m.xcurv=Int(Val(m.xcurv))
If !Between(m.xcurv,0,99)
m.xcurv=99
Endi
This.Curvature=m.xcurv
Endproc
Procedure image1.MouseDown
Lparameters nButton, nShift, nXCoord, nYCoord
Thisform.MouseDown(nButton, nShift, nXCoord, nYCoord)
Endproc
Procedure image1.Init
With This
.Left =0
.Top =0
.Width =.Parent.Width
.Height =.Parent.Height
.Stretch=2
.Anchor =15
.Picture="cheval.jpg"
.Visible=.F.
Endwith
Endproc
Procedure image1.RightClick
Thisform.RightClick()
Endproc
Procedure timer1.Timer
Sele ycurs
Try
Skip
Catch
Locate
Endtry
If Empty(yimage)
Locate
Endi
Thisform.image1.Visible=.T.
Thisform.image1.Picture=yimage
If Lastkey()=4 &&ctrl+d exit diaporama
This.Enabled=.F.
Thisform.image1.Picture=Thisform.xpict
Thisform.image1.Visible=.F.
Set Defa To (yrep)
Endi
Endproc
Enddefine
*
*End code
download the picture "cheval.jpg" to make on the form.
this.picture is used with the code above.
These images illustrate the three codes above.