https://vfpimaging.blogspot.com/2006/03/capture-screen-portions_7775.html
Autor: Cesar Ch.
Traducido por: Ana María Bisbé York
Este ejemplo, corto; pero poderoso emplea muchas llamadas a API, para accesos de memoria y conversión de datos desde el portapapeles. No necesita de ningún control OCX y trabaja con VFP desde la versión 5 hasta la 9. El autor lo ha creado porque mucha gente ha estado buscando herramientas para capturar imágenes desde cámaras web y otros accesorios de imágenes enlazados a programas. Este ejemplo muestra nuevamente que podemos hacer muchas cosas con Visual FoxPro. Echemos un vistazo a lo que el ha hecho en un formulario sencillo.
Este es uno de mis códigos preferidos de uno de mis colegas del foro brasileño www.foxbrasil.com.br/forum, Gelson L. Bremm, de Florianopolis - Brasil, quien me ha autorizado a publicarlo aquí. Pienso que realmente vale la pena compartirlo con el resto de la comunidad.
En este enlace puede encontrar más información sobre Gelson: http://www.foxbrasil.com.br/forum/viewtopic.php?t=2044
Desde aquí, puede descargar el código fuente que tiene debajo: https://bit.ly/CaptureScreens
*!* IMAGECAPTURE.PRG
*!* Autor : Gelson L. Bremm
*!* Descripción : Captura cualquier imagen de la pantalla
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 = "Capturar"
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 = "Capturar"
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("Esta carpeta ya contiene un archivo llamado '"+PROPER(JUSTFNAME(cNameFile))+;
"'"+CHR(13)+"¿Sobreescribir el archivo existente ?",36+256,"Confirmar sobreescribir") = 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("No hay ninguna imagen en el portapapeles.",48,"Error al crear el archivo")
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 al crear un archivo: " + cNameFile, "Operación no concluida")
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 = "Opciones"
Name = "Command1"
PROCEDURE Click
cOptMenu = ""
DEFINE POPUP _menu_clip SHORTCUT RELATIVE FROM MROW(), MCOL()
DEFINE BAR CNTBAR("_menu_clip")+1 OF _menu_clip PROMPT "Copiar al portapapeles"
ON SELECTION BAR CNTBAR("_menu_clip") OF _menu_clip cOptMenu = "CLIPBOARD"
DEFINE BAR CNTBAR("_menu_clip")+1 OF _menu_clip PROMPT "Copiar al archivo"
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
