A cool desktop zones captures

Published on May 19 2016 by Yousfi Benameur

                        
this VFP9 application works on systray with a summary contextuel menu(show/hide the form capture and exit application).
Can capture any visible zone of the desktop can be achieved with a top level form (alwaysontop=.t. or .f. at runtime) semi transparent (transparency adjustable in code).
this form have no titlebar.All operations can be made by keyboard keys in the form event Keypress or by contextuel menu (righclick simply on form).
this code builds a semi transparent form and capture all what is behind as image .
GdiplusX system.app is recquired to make this code working.can download the stable version (GDIPlusX_Source_v1.20) in this link:
https://vfpx.codeplex.com/releases/view/15083
extract the system.app and put it in source folder with this code.
it creates a folder "images" to store all captures( if not exists).
At any moment can rightclick on form to fire the contextuel menu or issue h or H for summary help.

form is movable (by mousedown) and resizable
get focus on the form and Press key:
h,H  help
e,E format image captured PNG,JPG,BMP,GIF
s,S save the zone to jpg image
v,V view the captured images in folder images created(can press x,X to change form.alwaysontop property).
b, B make the form resizable or no (no borders).for better precision use no border to capture  zone.can choose only the contour of form as capture area.
m,M maximize the form to whole screen area
c,C  change the form background color (for contrast zone/desktop)
x,X  change alwaysontop on or off
can adjust transparency (set to 150)
can also capture image of form contents with its backcolor as filter.

create a project,add a config.fpw(screen=off,resource=off), insert system.app as excluded  and compile an executable(72Ko if no debug,crypted).
system.app must be in source folder (or at least in windows\system32 to be always accessible).
for exe systray class is embed and compiled in project.on developpement mode systray(vcx/vct) must be located at usual in : home(1)+"samples\solution\toledo.

Note: the top level form is used to give only the 4 coordinates of the zone to capture and to give a visual pointing utility for the user.

Click on code to select [then copy] -click outside to deselect


*1* ycapture.prg

If ! _vfp.StartMode=0
On Shutdown Quit
Endi
Publi m.yrep
m.yrep=Addbs(Justpath(Sys(16,1)))
Set Defa To (m.yrep)

If ! File("system.app")
Messagebox("System.app must stay in source folder....cancelling!",16+4096,"Error")
Return .F.
Endi

If ! Directory(m.yrep+"images")
Md (m.yrep+"images")
Endi
Do System.App   &&do system.app if exe (system.app in same folder) -avoid locfile

Publi ySystr,ycap
Try
ySystr =Newobject("ysystray")
Catch
Messagebox("An error occured with systry class-try again",16+4096)
ySystr=Null
Return .F.
Endtry
ySystr.AddIconToSystray()
ycap=Newobject("ycapture")

_Screen.AddProperty("myvar","")
TEXT to _screen.myvar noshow
this is a desktop capture utility.
author:Yousfi Benameur  El Bayadh ALGERIA
ENDTEXT

Try
With m.ySystr
.ShowBalloonTip(_Screen.myvar,"Welcome",0,5)
Endwith
Catch
Messagebox("Balloon not supported in os version!",16+4096,"error",1000)
Endtry
Read Events

Define Class ysystray As Systray Of  Home(1)+"samples\solution\toledo\systray.vcx"  &&"systray.vcx"
IconFile = Home(1) + "Graphics\Icons\Misc\camera.ico"
TipText = "Desktop Captures"
MenuTextIsMPR = .F.
MenuText = "1;run/hide captures ;2;Exit"  &&menu integrated inside code

Procedure ProcessMenuEvent    &&event of systray class
Lparameters nMenuItemID
Do Case
 Case nMenuItemID = 0
    * User cleared the menu. Do nothing.
 Case nMenuItemID = 1
	If ycap.Visible=.T.
	   ycap.Hide()
	Else


	   With ycap
		  With ycap.ycopr
			 *   .Left=(.Parent.Width-.Width)/2
			 *   .Top =(.Parent.Height-.Height)/2
			 *   .Refresh
			 *   .Parent.Refresh
			 .Visible=.T.
		  Endwith

		  .Show()
		  .Visible=.T.
		  .timer1.Enabled=.T.
	   Endwith
	Endi

 Case nMenuItemID = 2        && Exit Application
	This.RemoveIconFromSystray()
	DoEvents
	ycap.Release
	Clear Events
Endcase

Endproc
Enddefine

*
Define Class ycapture As Form
Height = 467
Width = 800
ShowWindow = 2
AutoCenter = .T.
Caption = "yCaptures desktop zones "
WindowState = 0
AlwaysOnTop = .T.
BackColor = Rgb(64,0,0)
ytranspa = 150
cl = .F.
left0 = 0
top0 = 0
width0 = 0
height0 = 0
Max = .F.
yc=.F.
ext="JPG"

*"camera_mount2.png", ;

Add Object ycopr As ycopr With ;
Name = "ycopr"


Add Object timer1 As Timer With ;
Top = 48, ;
Left = 432, ;
Height = 23, ;
Width = 23, ;
Interval = 4000, ;
enabled=.F.,;
Name = "Timer1"

Procedure timer1.Timer
Thisform.ycopr.Visible=!Thisform.ycopr.Visible   &&.f.
This.Enabled=.F.
Endproc

Procedure Resize
This.ycopr.Resize
Endproc


Procedure ysave
Lparameters x,Y,w,h
If !Pcount()=4
 Return .F.
Endi
Thisform.Hide

Local m.ext
m.ext=Thisform.ext
Try
 Local loCaptureBmp As xfcBitmap
 With _Screen.System.Drawing
	Local loCapture As xfcBitmap
	*LPARAMETERS tHWnd, tiX, tiY, tiWidth, tiHeight, [tlEnsureVisible]
	loCapture = .Bitmap.Fromscreen(0,x,Y,w,h) &&capture zone desktop (hwnd=0)
	Sleep(500)
	Local m.xx,m.lcdest
	m.xx="capture_"+Ttoc(Datetime())
	m.xx=Strtran(m.xx,"/","_")
	m.xx=Strtran(m.xx,":","_")
	m.xx=Strtran(m.xx,";","_")
	m.lcdest=m.yrep+"images\"+m.xx+"."+m.ext
	Do Case
	   Case Upper(Thisform.ext)=="PNG"
		  loCapture.Save(m.lcdest,.imaging.imageformat.PNG)
	   Case Upper(Thisform.ext)=="JPG"
		  loCapture.Save(m.lcdest,.imaging.imageformat.JPEG)
	   Case Upper(Thisform.ext)=="BMP"
		  loCapture.Save(m.lcdest,.imaging.imageformat.BMP)
	   Case Upper(Thisform.ext)=="GIF"
		  loCapture.Save(m.lcdest,.imaging.imageformat.GIF)
	Endcase

 Endwith
Catch
Endtry

*verify image captured
If File(m.lcdest)
 *    Run/N explorer  &lcdest
 Messagebox( m.lcdest+Chr(13)+" .....done  -Issue v r V on form to see all captures" ,0+32+4096,'',1300)
Else
 Messagebox("An error was occured!",16+4096,"Error",1000)
Endi

Sleep(2000)
Wait Clea
Thisform.Show
bringWindowToTop(Thisform.HWnd)
Thisform.GotFocus
Endproc

Procedure yhelp
Local m.myvar
TEXT to m.myvar noshow
this code builds a semi transparent form and capture all what is behind as image .
it run on systray with a contextuel summary menu.
At any moment rightclick to fire the contextuel menu or issue h or H for summary help.
form is movable (by mousedown) and resizable
get focus on the form and Press key:
h,H  help
e,E format image captured PNG,JPG,BMP,GIF
s,S save the zone to jpg image
v,V view the captured images in folder images created.
b, B make the form reizable or no (no borders)-can choose only the contour of form as capture area.
m,M maximize the form to whole screen area
c,C  change the form background color (for contrast zone/desktop)
x,X  change alwaysontop on or off
can adjust transparency (set to 150)

The form is started first and can be hidden and run from the systray (show/hide).
the final exit app is made in systray.
ENDTEXT
Messagebox(m.myvar,0+32+4096,"Summary help")
Endproc

Procedure KeyPress
Lparameters nKeyCode, nShiftAltCtrl
If nKeyCode=27   &&ESC to exit form
 Thisform.Hide()
Endi

If nKeyCode=112 Or nKeyCode=80   &&p,P copyRight
 With Thisform.ycopr
	* .Left=(.Parent.Width-.Width)/2
	* .Top =(.Parent.Height-.Height)/2
	.Refresh
	.Parent.Refresh
	.Visible=!.Visible
 Endwith
Endi

If nKeyCode=101 Or nKeyCode=69   &&e ,E for image format PNG,JPG,BMP,GIF
 Local m.x
 m.x=Inputbox("Format image captured(PNG,JPG,BMP,GIF)","","JPG")
 If !Inlist(Upper(m.x),"PNG","JPG","BMP","GIF")
	m.x="JPG"
 Endi
 Thisform.ext=m.x
Endi

If nKeyCode=115 Or nKeyCode=83   &&s or S for saving zone to jpg
 Wait Window "Saving" Timeout 0.5
 Sleep(500)
 Local x,Y,w,h
 With Thisform
	x=.Left
	Y=.Top
	w=.Width
	h=.Height
	Thisform.ysave(x,Y,w,h)
 Endwith
Endi

If nKeyCode=118 Or nKeyCode=86   &&v or V
 Local m.oo
 m.oo=m.yrep+"images"
 Run/N explorer &oo
Endi

If nKeyCode=104 Or nKeyCode=72  &&h or H for help
 Thisform.yhelp()
Endi

If nKeyCode=109 Or nKeyCode=77   &&mm or M maximize form, restore
 Thisform.Max=!Thisform.Max

 Do Case
	Case Thisform.Max=.T.
	   With Thisform
		  .left0=.Left
		  .top0=.Top
		  .width0=.Width
		  .height0=.Height
		  *form must be entierly visible otherwise raise error in gdiplusX library
		  .Left=1
		  .Top=1
		  .Width =Sysmetric(1)-2
		  .Height=Sysmetric(2)-2
	   Endwith

	Case Thisform.Max=.F.
	   With Thisform
		  .Left=.left0
		  .Top=.top0
		  .Width=.width0
		  .Height=.height0
	   Endwith
 Endcase
Endi

If nKeyCode=99 Or nKeyCode=67  &&c or C form backcolor  (for contast)
 Local m.xcolor
 m.xcolor=Getcolor()
 If !m.xcolor=-1
	Thisform.BackColor=m.xcolor
	Thisform.ytranspar(Thisform.ytranspa)
 Endi
Endi

If nKeyCode=121 Or nKeyCode=89   &&y Y  make form 322x32 (pixels)-this is a vfp limitaion for minwidth & minHeight form property

 Local xsize,xwidth,xheight
 m.xsize=Inputbox("Type width,height (separated by comma)","","32,32")
 If Empty(m.xsize) Or !Getwordcount(m.xsize,',')=2
	Messagebox("Type dimensions as expected please!",16+4096,"error",1200)
	Return .F.
 Endi

 m.xwidth=Int(Val(Getwordnum(xsize,1,',')))
 If !Vartype(m.xwidth)="N"
	Return .F.
 Endi

 m.xheight=Int(Val(Getwordnum(xsize,2,',')))
 If !Vartype(m.xheight)="N"
	Return .F.
 Endi

 With Thisform
	.MinWidth=10
	.Width =m.xwidth
	.MinHeight=10
	.Height=m.xheight
	.Refresh
 Endwith

Endi

If nKeyCode=98 Or nKeyCode=66  &&b or B for borders ( to adjust capture area)
 Thisform.BorderStyle=Iif(Thisform.BorderStyle=0,3,0)
 If Thisform.yc=.T.
	Thisform.BorderStyle=0
	Thisform.BackColor=Rgb(64,0,0)
	Thisform.ytranspar(150)
	Thisform.yc=.F.
 Endi
Endi
If nKeyCode=120 Or nKeyCode=88  &&x,X alwaysontop .t./.f.
 Thisform.AlwaysOnTop=Iif(Thisform.AlwaysOnTop=.T.,.F.,.T.)
Endi

Endproc

Procedure Init
*DoDefault()
With Thisform
 .BorderStyle=0
 .AlwaysOnTop=.T.
 .TitleBar=0
 .BackColor=Rgb(64,0,0)    &&rgb(0,0,0)
 .ycopr.Resize()
Endwith
Thisform.ytranspar(150)
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

Declare Integer Sleep In kernel32 Integer
Declare Integer BringWindowToTop In user32    Integer
_Screen.WindowState=1
Endproc
Procedure ymenu
Define Popup raccourci SHORTCUT Relative From Mrow(),Mcol()
Define Bar 1 Of raccourci Prompt "Maximize-Restore"
Define Bar 2 Of raccourci Prompt "Backcolor"
Define Bar 3 Of raccourci Prompt "Borders-resize"
Define Bar 4 Of raccourci Prompt "Capture format"
Define Bar 5 Of raccourci Prompt "View captures"
Define Bar 6 Of raccourci Prompt "AlwaysonTop on/off"
Define Bar 7 Of raccourci Prompt "Transparency"
Define Bar 8 Of raccourci Prompt "Save capture"
Define Bar 9 Of raccourci Prompt "Summary help"
Define Bar 10 Of raccourci Prompt "Capture with backcolor "
Define Bar 11 Of raccourci Prompt "Draw Contour only"
Define Bar 12 Of raccourci Prompt "Any Area as n,n pixels"
Define Bar 13 Of raccourci Prompt "Exit"

On Selection Bar 1 Of raccourci _Screen.ActiveForm.KeyPress(109)
On Selection Bar 2 Of raccourci _Screen.ActiveForm.KeyPress(99)
On Selection Bar 3 Of raccourci _Screen.ActiveForm.KeyPress(98)
On Selection Bar 4 Of raccourci _Screen.ActiveForm.KeyPress(101)
On Selection Bar 5 Of raccourci _Screen.ActiveForm.KeyPress(118)
On Selection Bar 7 Of raccourci _Screen.ActiveForm._4n10krur3()
On Selection Bar 6 Of raccourci _Screen.ActiveForm.KeyPress(120)
On Selection Bar 8 Of raccourci _Screen.ActiveForm.KeyPress(115)
On Selection Bar 9 Of raccourci _Screen.ActiveForm.KeyPress(104)
On Selection Bar 10 Of raccourci _Screen.ActiveForm.ycapw()
On Selection Bar 11 Of raccourci _Screen.ActiveForm.ycontour()
On Selection Bar 12 Of raccourci _Screen.ActiveForm.KeyPress(121)
On Selection Bar 13 Of raccourci _Screen.ActiveForm.KeyPress(27)
Activate Popup raccourci

Endproc

Procedure ycontour()
Thisform.BorderStyle=3   &&1,2
Thisform.yc=.T.
#Define LWA_COLORKEY 1
#Define LWA_ALPHA 2
#Define GWL_EXSTYLE -20
#Define WS_EX_LAYERED 0x80000

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.ytranspa,LWA_COLORKEY)  &&
bringWindowToTop(Thisform.HWnd)
Endproc

Procedure ycapw()
&&capture this window
Declare Integer keybd_event In Win32API ;
 INTEGER, Integer, Integer, Integer
VK_SNAPSHOT = 0x2C
VK_LMENU = 0X12
KEYEVENTF_KEYUP = 2

*The following commands copy the active application window to the
*clipboard (the equivalent of ALT+PrintScrn):
Thisform.GotFocus()
DoEvents
keybd_event( VK_LMENU,    0,0, 0 )  && key down
keybd_event( VK_SNAPSHOT, 0, 0, 0 )
keybd_event( VK_SNAPSHOT, 0,  KEYEVENTF_KEYUP, 0 )
keybd_event( VK_LMENU,    0, KEYEVENTF_KEYUP, 0 )
DoEvents
Inkey(0.5)

Run/n3 "mspaint"
Inkey(2)
oshell=Createobject("wscript.shell")
oshell.sendkeys("^{v}")
oshell=Null
Endproc

Procedure ytranspar
Lparameters ytrans
If !Empty(ytrans)
 Thisform.ytranspa=ytrans

 #Define LWA_COLORKEY 1
 #Define LWA_ALPHA 2
 #Define GWL_EXSTYLE -20
 #Define WS_EX_LAYERED 0x80000

 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.ytranspa,LWA_ALPHA)  &&+LWA_COLORKEY
 bringWindowToTop(Thisform.HWnd)
Endi
Endproc

Procedure _4n10krur3
Local m.transpa
m.transpa=Int(Val(Inputbox("Set transparency 140-240","",Trans(Thisform.ytranspa))))
If ! Between(m.transpa,140,240)
 m.transpa=150
Endi
Thisform.ytranspa=m.transpa
Thisform.ytranspar(Thisform.ytranspa)
Endproc

Procedure RightClick
Thisform.ymenu()
Endproc

Procedure MouseDown
Lparameters nButton, nShift, nXCoord, nYCoord
lnHandle = Thisform.HWnd
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)
Endproc

Procedure Destroy
Clea Events
Endproc

Procedure Activate
Thisform.GotFocus
Endproc
Enddefine
*
*-- EndDefine: ycapture

*copyRight
Define Class ycopr As Container
Anchor = 0
Top = 24
Left = 192
Width = 264
Height = 396
BackStyle = 0
BorderWidth = 0
Name = "ycopr"

Add Object image1 As Image With ;
Picture = (Home(1)+"graphics\icons\misc\camera.ico"), ;
Stretch = 2, ;
BackStyle = 0, ;
Height = 216, ;
Left = 27, ;
Top = 1, ;
Width = 204, ;
Name = "Image1"

Add Object label2 As Label With ;
FontBold = .T., ;
FontName = "Segoe Script", ;
FontSize = 12, ;
WordWrap = .T., ;
Alignment = 2, ;
BackStyle = 0, ;
Caption = " yCapture"+Chr(13)+"©Copyright "+Chr(13)+"Yousfi Benameur"+Chr(13)+ "05/2016", ;
Height = 115, ;
Left = 0, ;
Top = 276, ;
Width = 313, ;
ForeColor = Rgb(255,255,0), ;
Name = "Label2"

Add Object label1 As Label With ;
FontBold = .T., ;
FontName = "Segoe Script", ;
FontSize = 12, ;
WordWrap = .T., ;
Alignment = 2, ;
BackStyle = 0, ;
Caption = " yCapture"+Chr(13)+"©Copyright "+Chr(13)+"Yousfi Benameur"+Chr(13)+ "05/2016", ;
Height = 115, ;
Left = 0+1, ;
Top = 276+1, ;
Width = 313, ;
ForeColor = Rgb(255,0,0), ;
Name = "Label1"

Procedure Resize
With This
 .Width=.Parent.Width/2
 .Height=0.7*.Parent.Height
 .Left=(.Parent.Width-.Width)/2
 .Top=(.Parent.Height-.Height)/2
 With .image1
	.Left=1
	.Top=1
	.Width=.Parent.Width-2
	.Height=0.65*.Parent.Height
 Endwith

 With .label1
	.FontSize=12
	.FontBold=.T.
	.Left=0
	.Top=.Parent.image1.Top+.Parent.image1.Height+2
	.WordWrap=.T.
	.ZOrder(0)
 Endwith

 Local m.delta
 m.delta=1
 With This.label2
	.FontSize=12
	.FontBold=.T.
	.Left=.Parent.label1.Left+m.delta
	.Top =.Parent.label1.Top+m.delta
	.WordWrap=.T.
	.ZOrder(1)
 Endwith
 .Refresh
Endwith

with this
local m.xfontsize
m.xfontsize=.label1.fontsize
.label1.fontsize=8
.label2.fontsize=8
for i=0 to 180 step 3
.label1.rotation =m.i
.label2.rotation =m.i
sleep(10)
endfor
for i=180 to 0 step -3
.label1.rotation =m.i
.label2.rotation =m.i
sleep(10)
endfor
.label1.rotation=0
.label2.rotation=0
sleep(0.5)
.label1.fontsize=m.xfontsize
.label2.fontsize=m.xfontsize
endwith
Endproc

Enddefine
*
*-- EndDefine: ycopr