{
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.
}interfaceuses
ClipBrd, Windows, SysUtils, GR32;
procedure CopyBitmap32ToClipboard(const Source: TBitmap32);
procedure PasteBitmap32FromClipboard(const Dest: TBitmap32);
function CanPasteBitmap32: Boolean;
implementationconst
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 thenraise Exception.Create(SysErrorMessage(ErrCode));
end;
function GetAlphaFormatHandle: Word;
beginif FAlphaFormatHandle = 0 thenbegin
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);
ifnot OpenClipboard(0) then
RaiseSysError
elsetry
Bytes := 4 + (Source.Width * Source.Height);
H := GlobalAlloc(GMEM_MOVEABLE and GMEM_DDESHARE, Bytes);
if H = 0 then
RaiseSysError;
P := GlobalLock(H);
if P = nilthen
RaiseSysError
elsetry
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) dobegin
P^ := Alpha^;
Inc(Alpha, 4);
Inc(P);
end;
finallyif (not GlobalUnlock(H)) thenif (GetLastError() <> GlobalUnlockBugErrorCode) then
RaiseSysError;
end;
SetClipboardData(GetAlphaFormatHandle, H);
finallyifnot CloseClipboard then
RaiseSysError;
end;
end;
procedure PasteBitmap32FromClipboard(const Dest: TBitmap32);
var
H: HGLOBAL;
ClipAlpha, Alpha: PByte;
I, Count, PixelCount: LongWord;
beginif Clipboard.HasFormat(CF_BITMAP) thenbegin
Dest.BeginUpdate;
try
Dest.Assign(Clipboard);
ifnot OpenClipboard(0) then
RaiseSysError
elsetry
H := GetClipboardData(GetAlphaFormatHandle);
if H <> 0 thenbegin
ClipAlpha := GlobalLock(H);
if ClipAlpha = nilthen
RaiseSysError
elsetry
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 dobegin
Alpha^ := ClipAlpha^;
Inc(Alpha, 4);
Inc(ClipAlpha);
end;
finallyif (not GlobalUnlock(H)) thenif (GetLastError() <> GlobalUnlockBugErrorCode) then
RaiseSysError;
end;
end;
finallyifnot 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:\test.jpg");
CopyBitmap32ToClipboard(bmp);
finally
bmp.Free;
end;
end;
Если Вас заинтересовала или понравилась информация по разработке на Delph - "Скопировать и вставить Bitmap из буфера", Вы можете поставить закладку в социальной сети или в своём блоге на данную страницу: Так же Вы можете задать вопрос по работе этого модуля или примера через форму обратной связи, в сообщение обязательно указывайте название или ссылку на статью!