Оформил: DeeCo
Автор: http://www.swissdelphicenter.ch

{ 
 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:\test.jpg');
     CopyBitmap32ToClipboard(bmp);
   finally
     bmp.Free;
   end;
 end;