A glass form as exiting windows effect

Published on by Yousfi Benameur

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.

this.picture is used with the code above.

These images illustrate the three codes above.
These images illustrate the three codes above.
These images illustrate the three codes above.
These images illustrate the three codes above.
These images illustrate the three codes above.
These images illustrate the three codes above.
These images illustrate the three codes above.

These images illustrate the three codes above.

Published on Visual foxpro, Form, API, Tranparency

To be informed of the latest articles, subscribe:
Comment on this post