Free hand captures as bitmaps
This code provides a free hand capture of any visible desktop window region by hand (with mouse).
It uses exclusively windows APIs and a table as cursor to gather the captured points.
The idea is to fire a top level form made alpha transparent (to see behind) and to capture any region with mouse.The captured region is confined by mouse as a simple drawing.
the gdi32 APIs does the job from the cursor built.(CreateRectRgn,CreatePolygonRgn,
the captured region is then sent to the clipboard by the API keybd_event who is equivalent to PRTSCREEN key
then the gdiplus APIs restore the clipboard as a normal image (can save as png,jpg,bmp,gif or ,tif...or even other gdiplus formats not enumerated in code(emf,..))
Select the code an d paste into a prg and run.can build a project to produce an executable.
-i put 2 years ago, in foxite this capture utility you can download (the rgion capture is made with gdiplusX , another solution):http://www.foxite.com/downloads/default.aspx?id=222
this make all known captures(window,screen,rectangular zône,free hand,roundrectangle...)
Can use r/R to reduce the transparent window and ESC to exit application.
*Begin Code
if !_vfp.startmode=0
On Shutdown Quit && in case you build exe from project
endi
Set Exact On
Set Safe Off
_Screen.AddProperty("yrest",.F.)
_Screen.AddProperty("ytype","jpg")
Publi m.yrep
m.yrep=Addbs(Justpath(Sys(16,1)))
Set Defa To (yrep)
Publi yform
yform=Newobject("ycap_fh")
yform.Show
Read Events
sleep(500)
If _Screen.yrest=.T.
=yrestore_image(_Screen.ytype)
Endi
Return
*
Define Class ycap_fh As Form
BorderStyle = 0
Top = 0
Left = 0
Height = 768
Width = 1024
ShowWindow = 2
Caption = "Form1"
Movable = .F.
FillStyle = 0
KeyPreview = .T.
TitleBar = 0
FillColor = Rgb(255,166,166)
posx = 0
posy = 0
hrgn = .F.
hrgnbase = .F.
xtjpeg = 90
yext = "jpg"
Name = "yFreeHand"
Procedure yregionOn
This.hrgnbase=0
This.hrgn=0
This.hrgnbase = CreateRectRgn(0,0,Thisform.Width,Thisform.Height)
#Define Alternate 1
#Define WINDING 2
lcPoints = Space(0)
Sele ycurs
Scan
lcPoints = lcPoints + Thisform.num2dword(x) + Thisform.num2dword(Y)
Endscan
This.hrgn =CreatePolygonRgn(@lcPoints,Reccount() ,WINDING)
#Define RGN_XOR 3 &&make the region transparent
Local m.yy
m.yy= CombineRgn(This.hrgnbase, This.hrgnbase, This.hrgn, RGN_XOR)
Local m.xx
m.xx = SetWindowRgn(Thisform.HWnd, This.hrgnbase, "TRUE") &&.t. dont work ?
DeleteObject(This.hrgn)
DeleteObject(This.hrgnbase)
Thisform.Cls &&clear red drawing
sleep(300)
Clear Dlls "CreateRectRgn","CreatePolygonRgn","CombineRgn","SetWindowRgn"
&&capture window
Declare Integer keybd_event In Win32API ;
INTEGER, Integer, Integer, Integer
VK_SNAPSHOT = 44 && from the winuser.h
VK_LMENU = 164
KEYEVENTF_KEYUP = 2
KEYEVENTF_EXTENDEDKEY = 1
*The following commands copy the active form window to the
*clipboard (the equivalent of ALT+PrintScrn):
DoEvents
keybd_event( VK_LMENU, 0, KEYEVENTF_EXTENDEDKEY, 0 ) && key down
keybd_event( VK_SNAPSHOT, 0, KEYEVENTF_EXTENDEDKEY, 0 )
keybd_event( VK_SNAPSHOT, 0, KEYEVENTF_EXTENDEDKEY + KEYEVENTF_KEYUP, 0 )
keybd_event( VK_LMENU, 0, KEYEVENTF_EXTENDEDKEY + KEYEVENTF_KEYUP, 0 )
DoEvents
sleep(300)
Thisform.Release
Endproc
Procedure num2dword
Lparameters lnValue
#Define m0 0x0000100
#Define m1 0x0010000
#Define m2 0x1000000
If lnValue < 0
lnValue = 0x100000000 + lnValue
Endif
Local b0, b1, b2, b3
b3 = Int(lnValue/m2)
b2 = Int((lnValue - b3*m2)/m1)
b1 = Int((lnValue - b3*m2 - b2*m1)/m0)
b0 = Mod(lnValue, m0)
Return Chr(b0)+Chr(b1)+Chr(b2)+Chr(b3)
Endproc
Procedure ytranspa
#Define LWA_COLORKEY 1
#Define LWA_ALPHA 2
#Define GWL_EXSTYLE -20
#Define WS_EX_LAYERED 0x80000
Declare Integer GetActiveWindow In user32
yHWnd=Thisform.HWnd
&&transparency
Local nExStyle, nRgb, nAlpha, nFlags
yHWnd=Thisform.HWnd
nExStyle = GetWindowLong(yHWnd, GWL_EXSTYLE)
nExStyle = Bitor(nExStyle, WS_EX_LAYERED)
= SetWindowLong(yHWnd, GWL_EXSTYLE, nExStyle)
nRgb=Rgb(255,0,255)
nAlpha=128
nFlags=2
= SetLayeredWindowAttributes(yHWnd, m.nRgb, m.nAlpha, m.nFlags)
*Messagebox("Press r/R to reduce the window,ESC to release!",0+32+4096,"",1000)
Endproc
Procedure KeyPress
Lparameters nKeyCode, nShiftAltCtrl
If nKeyCode=27 &&release form
Thisform.Release
Endi
If nKeyCode=114 Or nKeyCode=82 &&r/R reduce
Thisform.WindowState=1
Endi
Endproc
Procedure Init
Thisform.yext=Inputbox("save captures as: jpg,png,bmp,gif,tif","","jpg")
If Empty(Thisform.yext)
Thisform.yext=[jpg] &&&
Endi
If ! Inlist(Lower(Thisform.yext),;
"jpg","png","bmp","gif","tif")
Thisform.yext=[jpg] &&&
Endi
_Screen.WindowState=1 &&reduce vfp window to see behind
If !Directory(m.yrep+"captures")
Md (m.yrep+"captures")
Endi
Publi xtype,cl,ca
xtype=5 &&free hand
cl=0
ca=.T.
With Thisform
.Left=0
.Top=0
.Width=Sysmetric(1)
.Height=Sysmetric(2)+Sysmetric(9)+Sysmetric(4)
.hrgnbase=0
.hrgn=0
Endwith
Thisform.SetAll("mousepointer",15,"commandbutton")
Thisform.ytranspa()
Endproc
Procedure Destroy
This.hrgn=0
This.hrgnbase=0
With _Screen
.yrest=.T.
.ytype=Thisform.yext
Endwith
Clea Events
Endproc
Procedure Load
Close Data All
Declare Integer Sleep In kernel32 Integer
Declare Integer CreateRectRgn In gdi32;
INTEGER nLeftRect, Integer nTopRect,;
INTEGER nRightRect, Integer nBottomRect
Declare Integer CombineRgn In gdi32;
INTEGER hrgnDest, Integer hrgnSrc1,;
INTEGER hrgnSrc2,;
INTEGER fnCombineMode
Declare Long SetWindowRgn In WIN32API Long HWnd, Long hRgn, String bRedraw
Declare Integer CreatePolygonRgn In gdi32 String@ pPoints, Integer nPoints, Integer nfillmode &&vfp declaration
Declare Integer DeleteObject In gdi32 Integer hObject
Declare Integer OpenClipboard In user32 Integer HWnd
Declare Integer EmptyClipboard In user32
Declare Integer CloseClipboard In user32
=OpenClipboard(0)
* Handle to the window to be associated with the open clipboard
* If this parameter is NULL, the open clipboard is associated with the current task.
=EmptyClipboard() &&empty the clipboard
=CloseClipboard() &&mandatory to work with clipboard
Declare Integer GetClipboardData In User32 Integer
Declare Integer GdipCreateBitmapFromHBITMAP In GDIPlus.Dll Integer, Integer, Integer @
Declare Integer GdipSaveImageToFile In GDIPlus.Dll Integer,String,String @,String @
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 (x i,Y i) &&to record (x,y)p oints
Endproc
Procedure MouseDown
Lparameters nButton, nShift, nXCoord, nYCoord
If nButton=1 And cl=0 And ca=.T. And xtype=5
Thisform.Cls
x0=nXCoord
y0=nYCoord
This.MousePointer=2
Thisform.ForeColor=255
Thisform.DrawWidth=3
Thisform.DrawStyle=0
Thisform.PSet(x0,y0) && point drawing origin
Endi
Endproc
Procedure MouseMove
Lparameters nButton, nShift, nXCoord, nYCoord
If nButton=0
Thisform.MousePointer=0
Endi
If nButton=1 And cl=1 And ca=.T. And !xtype=5
Thisform.DrawWidth=3
Thisform.Box(x0,y0,nXCoord,nYCoord)
t0=Seconds()
Do While Seconds()-t0<=0.05
Enddo
Thisform.Cls
Endi
If nButton=1 And cl=0 And ca=.T. And xtype=5
x0=nXCoord
y0=nYCoord
This.MousePointer=2
Thisform.ForeColor=255
Thisform.DrawWidth=3
Thisform.DrawStyle=0
Thisform.Line(x0,y0)
&&point in visible form area
If Between(x0,0,Thisform.Width) And Between(y0,0,Thisform.Height)
Insert Into ycurs Values (x0,y0)
Endi
Endi
Endproc
Procedure MouseUp
Lparameters nButton, nShift, nXCoord, nYCoord
If nButton=1 And cl=0 And ca=.T. And xtype=5 &&free hand
Thisform.MousePointer=0
cl=1
Sele ycurs
Locate
Insert Into ycurs Values (x,Y) &&close curve
= SetLayeredWindowAttributes(Thisform.HWnd, 0, 0,0) &&opaque
Thisform.yregionOn()
DoEvents
Endi
Endproc
Enddefine
* Enddefine ycap_fh
Function yrestore_image
Lparameters xtype
If Pcount()=0
xtype="jpg"
Endi
xtype=Lower(xtype)
Declare Integer OpenClipboard In User32 Integer
Declare Integer CloseClipboard In User32
Declare Integer GetClipboardData In User32 Integer
Declare Integer GdipCreateBitmapFromHBITMAP In GDIPlus.Dll Integer, Integer, Integer @
Declare Integer GdipSaveImageToFile In GDIPlus.Dll Integer,String,String @,String @
Do Case
Case xtype="png" &&png
lqEncoderClsID_PNG=0h06F47C55041AD3119A730000F81EF32E &&PNGFormat
Case xtype="jpg" &&jpg
lqEncoderClsID_JPG=0h01F47C55041AD3119A730000F81EF32E &&JPGFormat
Case xtype="bmp" &&bmp
lqEncoderClsID_BMP=0h00F47C55041AD3119A730000F81EF32E &&BMPFormat
Case xtype="gif" &&gif
lqEncoderClsID_GIF=0h02F47C55041AD3119A730000F81EF32E &&GIFFormat
Case xtype="tif" &&tiff
lqEncoderClsID_TIF=0h05F47C55041AD3119A730000F81EF32E &&TIFFormat
Endcase
#Define CF_BITMAP 2
#Define CF_DIB 8
#Define IMAGE_BITMAP 0
* restore image saved before in local clipboard
=OpenClipboard(0)
hBitmap = GetClipboardData(CF_BITMAP)
hDib = GetClipboardData(CF_DIB)
=CloseClipboard()
If hBitmap=0
Messagebox("no captured image in clipboard!",16+4096)
Return .F.
Endi
Local m.x
m.x=Strtran(Ttoc(Datetime()),"\","_")
m.x=Strtran(m.x," ","_")
m.x=Strtran(m.x,';','_')
m.x=Strtran(m.x,':','_')
m.x=Strtran(m.x,'/','_')
lcOutputFile0=m.yrep+"captures\ytemp_"+m.x+"."+xtype
uBitmap=0
GdipCreateBitmapFromHBITMAP(hBitmap,2,@uBitmap)
lcOutputFile=Strconv(m.lcOutputFile0+Chr(0),5)
GdipSaveImageToFile(uBitmap,lcOutputFile,Eval("lqEncoderClsID_"+xtype),Null)
Messagebox("Image saved in captures folder",0+32+4096,500)
*run/n explorer /select, &lcoutputfile0
Endfunc
*End Code
to do:limit the window to the captured zône only instead screen window...(searching an API for this operation).