Как копировать и вставлять картинки через буфер обмена?

Code:

unit EG_ClipboardBitmap32;

{

Author William Egge. Этот адрес электронной почты защищён от спам-ботов. У вас должен быть включен JavaScript для просмотра.

January 17, 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;