2006-03-20

CAPTURE SCREEN PORTIONS

This short but powerful example makes use of many API calls, for memory access and data conversion to the clipboard. Does not require any ocx and works with vfp from version 5 to 9. The author created it because many people have been looking for tools to capture images from webcams and other image accessories linked to the programs. This sample shows again that we can do many cool things with visual foxpro. Have a look at what he's done with a simple form !

This is one of my preferred codes from my colleague from the brazilian forum http://www.vfpbrasil.com.br/ , Gelson L. Bremm, from Florianopolis - Brazil, who gave me the authorization to publish here. i think it's really worth to share with the rest of the community.

From here you can download the source code below.

*!* ImageCapture.prg
*!* Author : Gelson L. Bremm
*!* Description : Captures any image on the screen

public oCapturaImg
ocapturaimg = createobject("capturaimagem")
ocapturaimg.show()

define class capturaimagem as form
height = 147
width = 115
desktop = .t.
showwindow = 2
docreate = .t.
showtips = .t.
autocenter = .t.
caption = "capture"
halfheightcaption = .t.
maxbutton = .f.
minbutton = .f.
minheight = 80
alwaysontop = .t.
name = "capture"

add object command1 as mycmdbutton

procedure init
with this
.declarefunctions()
.resize()
endwith
endproc

proceduresettransparent
local lncontrolbottom, lncontrolright, lncontrolleft, lncontroltop, lnborderwidth, ;
lntitleheight, lnformheight, lnformwidth, lninnerrgn, lnouterrgn, lncombinedrgn, ;
lncontrolrgn, lncontrol, lnrgndiff, lnrgnor, lltrue

lnrgndiff = 4
lnrgnor = 2
lltrue = -1

with this
lnborderwidth = sysmetric(3)
lntitleheight = sysmetric(9)-sysmetric(4)
lnformwidth = .width + (lnborderwidth * 2)
lnformheight = .height + lntitleheight + lnborderwidth
lnouterrgn = createrectrgn(0, 0, lnformwidth, lnformheight)
lninnerrgn = createrectrgn(lnborderwidth, lntitleheight, ;
lnformwidth - lnborderwidth, lnformheight - lnborderwidth)
lncombinedrgn = createrectrgn(0, 0, 0, 0)
combinergn(lncombinedrgn, lnouterrgn, lninnerrgn, lnrgndiff)
for each control in .controls
lncontrolleft = control.left + lnborderwidth
lncontroltop = control.top + lntitleheight
lncontrolright = control.width + lncontrolleft
lncontrolbottom = control.height + lncontroltop
lncontrolrgn = createrectrgn(lncontrolleft, lncontroltop, lncontrolright, lncontrolbottom)
combinergn(lncombinedrgn, lncombinedrgn, lncontrolrgn, lnrgnor)
endfor
setwindowrgn(.hwnd , lncombinedrgn, lltrue)
endwith
endproc

procedurenum2dword
lparameters lnvalue

#define m0 256
#define m1 65536
#define m2 16777216

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

proceduredeclarefunctions
declare integer combinergn in "gdi32" integer hdestrgn, integer hrgn1, integer hrgn2, integer nmode
declare integer createrectrgn in "gdi32" integer x1, integer y1, integer x2, integer y2
declare integer setwindowrgn in "user32" integer hwnd, integer hrgn, integer nredraw

declare integer selectobject in gdi32 integer hdc, integer hobject
declare integer releasedc in user32 integer hwnd, integer hdc
declare integer createcompatibledc in gdi32 integer hdc
declare integer deleteobject in gdi32 integer hobject
declare integer deletedc in gdi32 integer hdc
declare integer closeclipboard in user32
declare integer getfocus in user32
declare integer emptyclipboard in user32
declare integer getwindowdc in user32 integer hwnd
declare integer openclipboard in user32 integer hwnd
declare integer setclipboarddata in user32 integer wformat, integer hmem
declare integer createcompatiblebitmap in gdi32;
integer hdc, integer nwidth, integer nheight
declare integer bitblt in gdi32;
integer hdestdc, integer x, integer y,;
integer nwidth, integer nheight, integer hsrcdc,;
integer xsrc, integer ysrc, integer dwrop

declare integer getactivewindow in user32
declare integer getclipboarddata in user32 integer uformat
declare integer globalalloc in kernel32 integer wflags, integer dwbytes
declare integer globalfree in kernel32 integer hmem

declare integer getobject in gdi32 as getobjecta;
integer hgdiobj, integer cbbuffer, string @lpvobject

declare integer getobjecttype in gdi32 integer h

declare rtlzeromemory in kernel32 as zeromemory;
integer dest, integer numbytes

declare integer getdibits in gdi32;
integer hdc, integer hbmp, integer ustartscan,;
integer cscanlines, integer lpvbits, string @lpbi,;
integer uusage

declare integer createfile in kernel32;
string lpfilename, integer dwdesiredaccess,;
integer dwsharemode, integer lpsecurityattr,;
integer dwcreationdisp, integer dwflagsandattrs,;
integer htemplatefile

declare integer closehandle in kernel32 integer hobject

declare sleep in kernel32 integer dwmilliseconds
endproc

procedure copytoclipboard
with this
.caption = "capturing"
.command1.left = .width+.command1.width
.cls()
.settransparent()
=sleep(100)

#define cf_bitmap 2
#define srccopy 13369376

lnleft = sysmetric(3)
lntop = sysmetric(4)+(sysmetric(20)-sysmetric(11))
lnright = 0
lnbottom = 0
lnwidth = .width
lnheight = .height-1

*hwnd = getfocus()
hdc = getwindowdc(.hwnd)
hvdc = createcompatibledc(hdc)
hbitmap = createcompatiblebitmap(hdc, lnwidth, lnheight)

= selectobject(hvdc, hbitmap)
= bitblt(hvdc, 0, 0, lnwidth, lnheight, hdc, lnleft, lntop, srccopy)
= openclipboard(.hwnd)
= emptyclipboard()
= setclipboarddata(cf_bitmap, hbitmap)
= closeclipboard()
= deleteobject(hbitmap)
= deletedc(hvdc)
= releasedc(.hwnd, hdc)

.command1.left = val(.command1.tag)
.settransparent()
.caption = "capture"
endwith
endproc

procedurecopytofile
#define cf_bitmap 2
#define srccopy 13369376
#define obj_bitmap 7
#define dib_rgb_colors 0
#define bfhdr_size 14
#define bhdr_size 40
#define generic_write 1073741824
#define file_share_write 2
#define create_always 2
#define file_attribute_normal 128
#define invalid_handle_value -1
#define bitmap_stru_size 24
#define bi_rgb 0
#define rgbquad_size 4
#define bhdr_size 40
#define gmem_fixed 0

local cdefault, cnamefile, hclipbmp
local pnwidth, pnheight, pnbitssize, pnrgbquadsize, pnbytesperscan
local hfile, lnfilesize, lnoffbits, lcbfilehdr
local lnbitsperpixel, lcbihdr, lcrgbquad
local lpbitsarray, lcbinfo
local hdc, hmemdc, lcbuffer

cdefault = fullpath(sys(5))
cnamefile = getpict("bmp")
set default to (cdefault)
if empty(cnamefile)
return
endif

if file(cnamefile)
if messagebox("this folder already contains a file called '"+proper(justfname(cnamefile))+"'"+chr(13)+"overwrite the existing file ?",36+256,"confirm overwriting") = 7
return
endif
endif
erase
(cnamefile)

with this
.copytoclipboard()

= openclipboard (0)
hclipbmp = getclipboarddata (cf_bitmap)
= closeclipboard()

if hclipbmp = 0 or getobjecttype(hclipbmp) # obj_bitmap
=messagebox("there is no image stored in the clipboard.",48,"error creating file")
return
endif

store0 to pnwidth, pnheight, pnbytesperscan, pnbitssize, pnrgbquadsize
lcbuffer = repli(chr(0), bitmap_stru_size)
if getobjecta (hclipbmp, bitmap_stru_size, @lcbuffer) # 0
pnwidth = asc(substr(lcbuffer, 5,1)) + ;
asc(substr(lcbuffer, 6,1)) * 256 +;
asc(substr(lcbuffer, 7,1)) * 65536 +;
asc(substr(lcbuffer, 8,1)) * 16777216

pnheight = asc(substr(lcbuffer, 9,1)) + ;
asc(substr(lcbuffer, 10,1)) * 256 +;
asc(substr(lcbuffer, 11,1)) * 65536 +;
asc(substr(lcbuffer, 12,1)) * 16777216
endif

lnbitsperpixel = 24
pnbytesperscan = int((pnwidth * lnbitsperpixel)/8)
if mod(pnbytesperscan, 4) # 0
pnbytesperscan = pnbytesperscan + 4 - mod(pnbytesperscan, 4)
endif

lcbihdr = .num2dword(bhdr_size) + .num2dword(pnwidth) +;
.num2dword(pnheight) + (chr(mod(1,256))+chr(int(1/256))) + (chr(mod(lnbitsperpixel,256))+chr(int(lnbitsperpixel/256))) +;
.num2dword(bi_rgb) + repli(chr(0), 20)

if lnbitsperpixel <= 8
pnrgbquadsize = (2^lnbitsperpixel) * rgbquad_size
lcrgbquad = repli(chr(0), pnrgbquadsize)
else
lcrgbquad = ""
endif
lcbinfo = lcbihdr + lcrgbquad
pnbitssize = pnheight * pnbytesperscan
lpbitsarray = globalalloc (gmem_fixed, pnbitssize)
= zeromemory (lpbitsarray, pnbitssize)

*hwnd = getactivewindow()
hdc = getwindowdc(.hwnd)
hmemdc = createcompatibledc (hdc)
= releasedc (.hwnd, hdc)
= getdibits (hmemdc, hclipbmp, 0, pnheight, lpbitsarray, @lcbinfo, dib_rgb_colors)

lnfilesize = bfhdr_size + bhdr_size + pnrgbquadsize + pnbitssize
lnoffbits = bfhdr_size + bhdr_size + pnrgbquadsize
lcbfilehdr = "bm" + .num2dword(lnfilesize) + .num2dword(0) + .num2dword(lnoffbits)

hfile = createfile (cnamefile, generic_write, file_share_write, 0, create_always, file_attribute_normal, 0)

if hfile # invalid_handle_value
declare integer writefile in kernel32;
integer hfile, string @lpbuffer, integer nbt2write,;
integer @lpbtwritten, integer lpoverlapped
= writefile (hfile, @lcbfilehdr, len(lcbfilehdr), 0, 0)
= writefile (hfile, @lcbinfo, len(lcbinfo), 0, 0)

declare integer writefile in kernel32;
integer hfile, integer lpbuffer, integer nbt2write,;
integer @lpbtwritten, integer lpoverlapped
= writefile (hfile, lpbitsarray, pnbitssize, 0, 0)
= closehandle (hfile)
else
= messagebox("error creating file: " + cnamefile, "task not completed")
endif

= globalfree(lpbitsarray)
= deletedc (hmemdc)
= deleteobject (hclipbmp)
endwith
endproc

procedureresize
with this
.command1.left = .width-.command1.width
.command1.top = .height-.command1.height
.command1.tag = allt(str(.command1.left))

.settransparent()
endwith
endproc

procedure destroy
ocapturaimg = .f.
release ocapturaimg
endproc
enddefine

define classmycmdbutton as commandbutton
top = 126
left = 97
height = 21
width = 18
fontname = "webdings"
caption = "6"
tooltiptext = "options"
name = "command1"

procedure click
coptmenu = ""
define popup _menu_clip shortcut relative from mrow(), mcol()
define bar cntbar("_menu_clip")+1 of _menu_clip prompt "copy to clipboard"
on selection bar cntbar("_menu_clip") of _menu_clip coptmenu = "clipboard"
define bar cntbar("_menu_clip")+1 of _menu_clip prompt "copy to file"
on selection bar cntbar("_menu_clip") of _menu_clip coptmenu = "file"
activate popup _menu_clip
release popups _menu_clip

do case
case
coptmenu == "clipboard"
thisform.copytoclipboard()

case coptmenu == "file"
thisform.copytofile()
endcase
endproc
enddefine

6 comments:

  1. This is absolutely cool!  Thanks for the great weblog information, I have really enjoyed reading, learning and implementing information from your weblogs.

    ReplyDelete
  2. Saya sungguh senang membaca Blog anda. Sungguh pelajaran berharga buat saya dan rekan - rekan Foxer.....


    Thx Brother.....u did great work

    ReplyDelete
  3. That is great, i believe that the visual foxpro can be used to implement some cool operations, not only the promise tool of management of the database!

    ReplyDelete
  4. Versión en Español de este artículo en / Spanish version at http://www.portalfox.com/article.php?sid=2213

    ReplyDelete
  5. This is awesome!


    I would like an even simpler version that captures the form to the clipboard. What do you suggest?

    Hi,
    That's pretty simple with GdiPlusX.
    LOCAL loBmp as xfcBitmap
    loBmp = .Bitmap.FromScreen(Thisform)
    loBmp.ToClipboard()

    ReplyDelete
  6. Hi, I tried to use your code to develop a screen captering tool, but I have some problems.


    1./ When capturing 2 images, the second image is the same image as the first one.

    2./ I managed to customize the form. Transaparency works fine, but the screen schots are always white!


    I'm developing in VFP 9 on Win7


    Please help...

    ReplyDelete