René Nyffenegger's collection of things on the web
René Nyffenegger on Oracle - Most wanted - Feedback -
 

HWND to clipboard [VBA]

option explicit

declare function CloseClipboard     lib "user32"   (                                         ) as long
declare function  OpenClipboard     lib "user32"   (byVal hWnd as long                       ) as long
declare function EmptyClipboard     lib "user32"   (                                         ) as long
declare function   SetClipboardData lib "user32"   (byVal wFormat as long, byVal hMem as long) as long


declare function GetActiveWindow        Lib "user32" () as long
declare function GetDesktopWindow       Lib "user32" () as long
declare Sub      GetWindowRect          Lib "user32" (byVal hWnd as long, lpRect as typRect)

declare function GetDC                  Lib "user32" (byVal hWnd as long) as long
Declare function CreateCompatibleDC     Lib "Gdi32"  (byVal hdc  as long) as long
Declare function CreateCompatibleBitmap Lib "Gdi32"  (byVal hdc  As long, byVal nWidth as long, byVal nHeight as long) as long
declare function SelectObject           Lib "Gdi32"  (byVal hdc  as long, byVal hObject as long) as long

Declare function BitBlt Lib "Gdi32" (byVal hDestDC as long, _
                                     byVal X       as long, _
                                     byVal Y       as long, _
                                     byVal nWidth  as long, _
                                     byVal nHeight as long, _
                                     byVal hSrcDC  as long, _
                                     byVal XSrc    as long, _
                                     byVal YSrc    as long, _
                                     byVal dwRop   as long) as long

declare function ReleaseDC Lib "user32" (byVal hWnd as long, byVal hdc as long) as long
declare function DeleteDC  Lib "Gdi32"  (byVal hdc  as long                   ) as long


type typRect
          left   as long
          top    as long
          right  as long
          bottom as long
end type

private const SRCCOPY   = &HCC0020
private const CF_BITMAP =        2

sub clipboard_2() 
  call screenDump()
end sub


private function screenDump()
 dim deskHwnd As long
     deskHwnd = GetDesktopWindow()

 dim AccessHwnd As long  
     AccessHwnd = GetActiveWindow()     

     dim rect As typRect

     call GetWindowRect(AccessHwnd, rect)

     dim fwidth  as long 
     dim fheight as long
     fwidth  = rect.right  - rect.left
     fheight = rect.bottom - rect.top
     
 dim hdc As long
     hdc     = GetDC(deskHwnd)

 dim hdcMem As long
     hdcMem  = CreateCompatibleDC(hdc)

 dim hBitmap As long
     hBitmap = CreateCompatibleBitmap(hdc, fwidth, fheight)
 
 dim dummy As long
     if hBitmap <> 0 Then
         dummy = SelectObject(hdcMem, hBitmap)
         dummy = BitBlt(hdcMem, 0, 0, fwidth, fheight, hdc, rect.left, rect.top, SRCCOPY)
         
         dummy = OpenClipboard(deskHwnd)
         dummy = EmptyClipboard()
         dummy = SetClipboardData(CF_BITMAP, hBitmap)
         dummy = CloseClipboard()
 
     end if
     
     dummy = DeleteDC (hdcMem)
     dummy = ReleaseDC(deskHwnd, hdc)
     
     msgBox "Copied", vbInformation, "***"
 
end function