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 example 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 www.foxbrasil.com.br/forum , 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.
At this link you can find more codes from Gelson :
http://www.foxbrasil.com.br/forum/viewtopic.php?t=2044
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
PROCEDURE SetTransparent
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
PROCEDURE num2dword
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
PROCEDURE declarefunctions
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
PROCEDURE CopyToFile
#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 forlder 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
STORE 0 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
PROCEDURE Resize
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 CLASS myCmdButton 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