Скопировать и вставить Bitmap из буфера

Советы » Буфер обмена » Скопировать и вставить Bitmap из буфера

{ 
 In order to run this example you will need the GR32 Unit from the package 
 http://www.g32.org/files/graphics32/graphics32-1_5_1.zip 
 to run this example. 
}

 unit

EG_ClipboardBitmap32; { Author William Egge. egge@eggcentric.com January 17, 2002 Compiles with ver 1.2 patch #1 of Graphics32 This unit will copy and paste Bitmap32 pixels to the clipboard and retain the alpha channel. The clipboard data will still work with regular paint programs because this unit adds a new format only for the alpha channel and is kept seperate from the regular bitmap storage. } interface

uses

ClipBrd, Windows, SysUtils, GR32; procedure

CopyBitmap32ToClipboard(const

Source: TBitmap32); procedure

PasteBitmap32FromClipboard(const

Dest: TBitmap32); function

CanPasteBitmap32: Boolean; implementation

const

RegisterName = 'G32 Bitmap32 Alpha Channel'; GlobalUnlockBugErrorCode = ERROR_INVALID_PARAMETER; var

FAlphaFormatHandle: Word = 0; procedure

RaiseSysError; var

ErrCode: LongWord; begin

ErrCode := GetLastError(); if

ErrCode <> NO_ERROR then

raise

Exception.Create(SysErrorMessage(ErrCode)); end

; function

GetAlphaFormatHandle: Word; begin

if

FAlphaFormatHandle = 0 then

begin

FAlphaFormatHandle := RegisterClipboardFormat(RegisterName); if

FAlphaFormatHandle = 0 then

RaiseSysError; end

; Result := FAlphaFormatHandle; end

; function

CanPasteBitmap32: Boolean; begin

Result := Clipboard.HasFormat(CF_BITMAP); end

; procedure

CopyBitmap32ToClipboard(const

Source: TBitmap32); var

H: HGLOBAL; Bytes: LongWord; P, Alpha: PByte; I: Integer; begin

Clipboard.Assign(Source); if

not

OpenClipboard(0) then

RaiseSysError else

try

Bytes := 4 + (Source.Width * Source.Height); H := GlobalAlloc(GMEM_MOVEABLE and

GMEM_DDESHARE, Bytes); if

H = 0 then

RaiseSysError; P := GlobalLock(H); if

P = nil

then

RaiseSysError else

try

PLongWord(P)^ := Bytes - 4; Inc(P, 4); // Copy Alpha into Array Alpha := Pointer(Source.Bits); Inc(Alpha, 3); // Align with Alpha for

I := 1 to

(Source.Width * Source.Height) do

begin

P^ := Alpha^; Inc(Alpha, 4); Inc(P); end

; finally

if

(not

GlobalUnlock(H)) then

if

(GetLastError() <> GlobalUnlockBugErrorCode) then

RaiseSysError; end

; SetClipboardData(GetAlphaFormatHandle, H); finally

if

not

CloseClipboard then

RaiseSysError; end

; end

; procedure

PasteBitmap32FromClipboard(const

Dest: TBitmap32); var

H: HGLOBAL; ClipAlpha, Alpha: PByte; I, Count, PixelCount: LongWord; begin

if

Clipboard.HasFormat(CF_BITMAP) then

begin

Dest.BeginUpdate; try

Dest.Assign(Clipboard); if

not

OpenClipboard(0) then

RaiseSysError else

try

H := GetClipboardData(GetAlphaFormatHandle); if

H <> 0 then

begin

ClipAlpha := GlobalLock(H); if

ClipAlpha = nil

then

RaiseSysError else

try

Alpha := Pointer(Dest.Bits); Inc(Alpha, 3); // Align with Alpha Count := PLongWord(ClipAlpha)^; Inc(ClipAlpha, 4); PixelCount := Dest.Width * Dest.Height; Assert(Count = PixelCount, 'Alpha Count does not match Bitmap pixel Count, PasteBitmap32FromClipboard(const Dest: TBitmap32);'); // Should not happen, but if it does then this is a safety catch. if

Count > PixelCount then

Count := PixelCount; for

I := 1 to

Count do

begin

Alpha^ := ClipAlpha^; Inc(Alpha, 4); Inc(ClipAlpha); end

; finally

if

(not

GlobalUnlock(H)) then

if

(GetLastError() <> GlobalUnlockBugErrorCode) then

RaiseSysError; end

; end

; finally

if

not

CloseClipboard then

RaiseSysError; end

; finally

Dest.EndUpdate; Dest.Changed; end

; end

; end

; end

. // Example Call: {uses JPEG;} procedure

TForm1.Button1Click(Sender: TObject); var

bmp: TBitmap32; begin

bmp := TBitmap32.Create; try

bmp.LoadFromFile('C: est.jpg'); CopyBitmap32ToClipboard(bmp); finally

bmp.Free; end

; end

;

Другое по теме:

Категории

Статьи

Советы

Copyright © 2022 - All Rights Reserved - www.delphirus.com