A cool desktop zones captures
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
capture any visible zone on desktop to image.just adjust the semi transparent form and issue s or S or menu item..
Important:All Codes above are tested on VFP9SP2 & windows 10 pro .
Please come back with any bug.correcting code is usefull to all readers.