...ein Bitmap in die Zwischenablage kopieren/aus ihr einfügen?

Autor: William Egge

Kategorie: Grafik

{
 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;

 

printed from
www.swissdelphicenter.ch
developers knowledge base