Captar porciones de pantalla

Artículo original: CAPTURE SCREEN PORTIONS
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