REBOL [
    title:   "Capture Screen"
    name:    'capture-screen
    file:    %capture-screen.r
    author:  ["Gregg Irwin" "Christian Ensel"]
    version: 0.3.0
    date:    5-Apr-2007
    purpose: "(Microsoft/Windows only:) Returns screenshot as an image (or NONE in case of failure)."
    example: [
        if snapshot: capture-screen [
            view center-face layout/tight compose [img: image snapshot (snapshot/size) [quit] effect [colorize coal]]
        ]
    ]
    library: [
        level:          'intermediate
        Platform:       'win
        type:           [function]
        code:           'function
        domain:         [win-api graphics]
        license:        'BSD
        support:        none
        see-also:       none
        tested-under:   [view 1.3.2.3.1 on [WinXP] "CHE"]
    ]
]                   

context [
    user32.dll:   load/library %user32.dll
    gdi32.dll:    load/library %gdi32.dll
   
    &SM_CXSCREEN:             0       
    &SM_CYSCREEN:             1       
    &SRCCOPY:          13369376 #{CC0020}
    &CAPTUREBLT:     1073741824 #{40000000}
    &CLR_INVALID:         65535 #{FFFF}
    &BI_RGB:                  0
    &DIB_RGB_COLORS:          0
    
    BITMAP:             make struct! [Type [integer!] Width [integer!] Height [integer!] WidthBytes [integer!] Planes [short] BitsPixel [short] Bits [char*]] none
    BITMAPINFOHEADER:   make struct! [Size [integer!] Width [integer!] Height [integer!] Planes [short] BitCount [short] Compression [integer!] SizeImage [integer!] XPelsPerMeter [integer!] YPelsPerMeter [integer!] ClrUsed [integer!] ClrImportant [integer!]] none
;   RGBQUAD:            make struct! [Blue [char!] Green [char!] Red [char!] Reserved [char!]] none
;   BITMAPINFO:         make struct! compose/deep/only [Header [struct! (first BITMAPINFOHEADER)] Colors [struct! (first RGBQUAD)]] none                
                                                         
    GetSystemMetrics:       make routine! [Index [integer!] return: [integer!]] user32.dll "GetSystemMetrics"
    GetDesktopWindow:       make routine! [return: [integer!]] user32.dll "GetDesktopWindow"     
    GetDC:                  make routine! [Wnd [integer!] return: [integer!]] user32.dll "GetDC"
    CreateCompatibleDC:     make routine! [DC [integer!] return: [integer!]] gdi32.dll "CreateCompatibleDC"
    CreateCompatibleBitmap: make routine! [DC [integer!] Width [integer!] Height [integer!] return: [integer!]] gdi32.dll "CreateCompatibleBitmap"
    SelectObject:           make routine! [DC [integer!] Object [integer!] return: [integer!]] gdi32.dll "SelectObject"
    BitBlt:                 make routine! [DCDest [integer!] XDest [integer!] YDest [integer!] Width [integer!] Height [integer!] DCSrc [integer!] XSrc [integer!] YSrc [integer!] ROp [integer!] return: [integer!]] gdi32.dll "BitBlt"
    GetPixel:               make routine! [DC [integer!] x [integer!] y [integer!] return: [integer!]] gdi32.dll "GetPixel"
    ReleaseDC:              make routine! [Wnd [integer!] DC [integer!] return: [integer!]] user32.dll "ReleaseDC"
    DeleteDC:               make routine! [DC [integer!] return: [integer!]] gdi32.dll "DeleteDC"
    DeleteObject:           make routine! [Object [integer!] return: [integer!]] gdi32.dll "DeleteObject"
    GetObject:              make routine! [Object [integer!] Count [integer!] Object [struct* [(first BITMAP)]] return: [integer!]] gdi32.dll "GetObjectA"
    GetDIBits:              make routine! [DC [integer!] Bitmap [integer!] StartScan [integer!] ScanLines [integer!] Bits [image!] BI [struct* [(first BITMAPINFO)]] Usage [integer!] return: [integer!]] gdi32.dll "GetDIBits" 
  
    require: func ["Throws NONE if condition isn't met." [throw] argument] [unless not zero? argument [throw none]]
    
    set 'capture-screen func [
        "(Microsoft/Windows 32bit-screens only:) Returns screenshot as an image (or NONE in case of failure)." 
        /local 
            n.ScreenWidth n.ScreenHeight h.DesktopWnd h.DesktopDC h.CaptureDC s
            h.CaptureBitmap h.Bitmap h.BitmapInfo h.BitmapInfoHeader img.Snapshot
    ][  
        img.Snapshot: catch [
            require n.ScreenWidth:   GetSystemMetrics &SM_CXSCREEN                
            require n.ScreenHeight:  GetSystemMetrics &SM_CYSCREEN
            require h.DesktopWnd:    GetDesktopWindow
            require h.DesktopDC:     GetDC h.DesktopWnd
            require h.CaptureDC:     CreateCompatibleDC h.DesktopDC
            require h.CaptureBitmap: CreateCompatibleBitmap h.DesktopDC n.ScreenWidth n.ScreenHeight
            
            require SelectObject h.CaptureDC h.CaptureBitmap
            require BitBlt h.CaptureDC 0 0 n.ScreenWidth n.ScreenHeight h.DesktopDC 0 0 &SRCCOPY or &CAPTUREBLT 
            
            h.Bitmap:           make struct! BITMAP none            
            require GetObject h.CaptureBitmap (length? third h.Bitmap) h.Bitmap 
            
            img.Snapshot:       make image!  as-pair h.Bitmap/Width h.Bitmap/Height
            h.BitmapInfoHeader: make struct! BITMAPINFOHEADER reduce [40 h.Bitmap/Width h.Bitmap/Height h.Bitmap/Planes 32 &BI_RGB 0 0 0 0 0]
                               
            ;-- The docs say GEtDIBits expects a BITMAPINFO, not a -HEADER, but I wasn't able to get this working. Additionally, the scanlines
            ;   copied are reversed vertically, which is why that at EFFECT [FLIP 0x1] is necessary.
            ;
;           h.BitmapInfo:       make struct! BITMAPINFO       compose [(second h.BitmapInfoHeader) (second RGBQuad)]

            require GetDIBits h.CaptureDC h.CaptureBitmap 0 h.Bitmap/Height img.Snapshot h.BitmapInfoHeader &DIB_RGB_COLORS
            
            img.Snapshot/alpha: 0
            to image! layout/tight compose [image img.Snapshot (img.Snapshot/size) effect [flip 0x1]]
        ]
        
        if h.DesktopDC     [ReleaseDC h.DesktopWnd h.DesktopDC]                             
        if h.CaptureDC     [DeleteDC h.CaptureDC]                                                   
        if h.CaptureBitmap [DeleteObject h.CaptureBitmap]   
    
        img.Snapshot
    ]
]