REBOL [ title: "Clipboard" name: 'clipboard file: %clipboard.r author: "Christian Ensel" version: 0.3.1 date: 18-12-2008 purpose: "(Microsoft/Windows only:) Read and write text, bitmaps and files from and to the clipboard." example: [ clip: read-clip write-clip "Test" write-clip logo.gif ] library: [ level: 'intermediate Platform: 'win type: [function] code: 'function domain: [win-api graphics] license: 'BSD support: none see-also: none tested-under: [view 2.7.6.3.1 on [WinXP] "CHE"] ] ] context [ user32.dll: load/library %user32.dll gdi32.dll: load/library %gdi32.dll shell32.dll: load/library %shell32.dll kernel32.dll: load/library %kernel32.dll &bi-rgb: 0 &dib-rgb-colors: 0 &cf-text: 1 &cf-bitmap: 2 &cf-hdrop: 15 ; &cf-metafilepict: 3 ; &cf-sylk: 4 ; &cf-dif: 5 ; &cf-tiff: 6 ; &cf-oemtext: 7 ; &cf-dib: 8 ; &cf-palette: 9 ; &cf-pendata: 10 ; &cf-riff: 11 ; &cf-wave: 12 ; &cf-unicodetext: 13 ; &cf-enhmetafile: 14 ; &cf-locale: 16 ; &cf-max: 17 ; &cf-ownerdisplay: 128 ; &cf-dsptext: 129 ; &cf-dspbitmap: 130 ; &cf-dspmetafilepict: 131 ; &cf-dspenhmetafile: 142 bitmap!: make struct! [Type [integer!] Width [integer!] Height [integer!] WidthBytes [integer!] Planes [short] BitsPixel [short] Bits [char*]] none bitmap-info-header!: 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 open-clipboard: make routine! [h.Window [integer!] return: [integer!]] user32.dll "OpenClipboard" in-clipboard?: make routine! [format [integer!] return: [integer!]] user32.dll "IsClipboardFormatAvailable" read-clipboard: make routine! [format [integer!] return: [integer!]] user32.dll "GetClipboardData" clear-clipboard: make routine! [return: [integer!]] user32.dll "EmptyClipboard" write-clipboard: make routine! [format [integer!] h.mem [integer!] return: [integer!]] user32.dll "SetClipboardData" close-clipboard: make routine! [return: [integer!]] user32.dll "CloseClipboard" create-bitmap: make routine! [width [integer!] height [integer!] planes [integer!] bits-per-pel [integer!] lpv-bits [image!] return: [integer!]] gdi32.dll "CreateBitmap" get-desktop: make routine! [return: [integer!]] user32.dll "GetDesktopWindow" get-dc: make routine! [h.Window [integer!] return: [integer!]] user32.dll "GetDC" release-dc: make routine! [h.Window [integer!] DC [integer!] return: [integer!]] user32.dll "ReleaseDC" delete-dc: make routine! [DC [integer!] return: [integer!]] gdi32.dll "DeleteDC" create-compatible-dc: make routine! [DC [integer!] return: [integer!]] gdi32.dll "CreateCompatibleDC" get-object: make routine! [Object [integer!] Count [integer!] Object [struct* [(first BITMAP)]] return: [integer!]] gdi32.dll "GetObjectA" get-dibits: make routine! [DC [integer!] Bitmap [integer!] StartScan [integer!] ScanLines [integer!] Bits [image!] BI [struct* [(first BITMAPINFO)]] Usage [integer!] return: [integer!]] gdi32.dll "GetDIBits" drag-query-file: make routine! [h.Drop [integer!] File [integer!] buffer [integer!] size [integer!] return: [integer!]] shell32.dll "DragQueryFileA" drag-query-filename: make routine! [h.Drop [integer!] File [integer!] buffer [string!] size [integer!] return: [integer!]] shell32.dll "DragQueryFileA" string-length?: make routine! [string [integer!] return: [integer!]] kernel32.dll "lstrlen" copy-memory: make routine! [dest [string!] source [integer!] length [integer!] return: [integer!]] kernel32.dll "RtlMoveMemory" lock-global: make routine! [address [integer!] return: [integer!]] kernel32.dll "GlobalLock" unlock-global: make routine! [address [integer!] return: [integer!]] kernel32.dll "GlobalUnlock" require: func ["Throws NONE if condition isn't met." [throw] argument] [unless not zero? argument [throw none]] success?: func [value] [not zero? value] set 'read-clip func [ "[Microsoft/Windows] Retrieve text, bitmaps and files from the clipboard (NONE otherwise)." /local clip clipboard format h.bitmap h.desktop h.desktop-dc h.compatible-dc bitmap image bitmap-info-header h.drop files count size name ][ clip: catch [ require clipboard: open-clipboard 0 any [ if success? in-clipboard? &cf-bitmap [ require h.bitmap: read-clipboard &cf-bitmap require h.desktop: get-desktop require h.desktop-dc: get-dc h.desktop require h.compatible-dc: create-compatible-dc h.desktop-dc bitmap: make struct! bitmap! none require get-object h.bitmap (length? third bitmap) bitmap bitmap-info-header: make struct! bitmap-info-header! reduce [40 bitmap/width bitmap/height bitmap/planes 32 &bi-rgb 0 0 0 0 0] image: make image! as-pair bitmap/width bitmap/height require get-dibits h.compatible-dc h.bitmap 0 bitmap/height image bitmap-info-header &dib-rgb-colors to image! layout/tight compose [image (image/alpha: 0 image) (image/size) effect [flip 0x1]] ] if success? in-clipboard? &cf-hdrop [ require h.drop: read-clipboard &cf-hdrop require count: drag-query-file h.drop -1 0 0 files: make block! count for file 0 count - 1 1 [ all [ success? size: drag-query-file h.drop file 0 0 name: head insert/dup copy "" "^@" size: size + 1 success? drag-query-filename h.drop file name size append files to-rebol-file to file! copy/part name size - 1 ] ] any [if empty? files [none] if empty? next files [first files] files] ] if success? in-clipboard? &cf-text [ ;require address: read-clipboard &cf-text ;require length: string-length? address ; ;string: head insert/dup copy "" "^@" length ;require lock-global address ; ;string: if success? copy-memory string address length [string] ;require unlock-global address ; ;string read clipboard:// ] ] ] if h.desktop-dc [release-dc h.desktop h.desktop-dc] if h.compatible-dc [delete-dc h.compatible-dc] if clipboard [close-clipboard] clip ] set 'write-clip func [ "[Microsoft/Windows] Write text or bitmaps to the clipboard." clip [any-string! image!] "Clip to write" /local clipboard format h.bitmap h.desktop h.desktop-dc h.compatible-dc bitmap image bitmap-info-header h.drop files count size name ][ clip: catch [ require clipboard: open-clipboard 0 any [ if image? clip [ require clear-clipboard require h.bitmap: create-bitmap clip/size/x clip/size/y 1 32 clip require write-clipboard &cf-bitmap h.bitmap clip ] if any-string? clip [ write clipboard:// clip clip ] ] ] if h.desktop-dc [release-dc h.desktop h.desktop-dc] if h.compatible-dc [delete-dc h.compatible-dc] if clipboard [close-clipboard] clip ] ]