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

Материал из DRKB

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

Некоторые функции для копирования и вставки Bitmap-объектов через буфер обмена.

function CopyClipToBuf(DC: HDC; Left, Top, Width, Height: Integer;
  Rop: LongInt; var CopyDC: HDC; var CopyBitmap: HBitmap): Boolean;
var
  TempBitmap: HBitmap;
begin
  Result := False;
  CopyDC := 0;
  CopyBitmap := 0;
  if DC <> 0 then
  begin
    CopyDC := CreateCompatibleDC(DC);
    if CopyDC <> 0 then
    begin
      CopyBitmap := CreateCompatibleBitmap(DC, Width, Height);
      if CopyBitmap <> 0 then
      begin
        TempBitmap := CopyBitmap;
        CopyBitmap := SelectObject(CopyDC, CopyBitmap);
        Result := BitBlt(CopyDC, 0, 0, Width, Height, DC, Left, Top, Rop);
        CopyBitmap := TempBitmap;
      end;
    end;
  end;
end;


function CopyBufToClip(DC: HDC; var CopyDC: HDC; var CopyBitmap: HBitmap;
  Left, Top, Width, Height: Integer;
  Rop: LongInt; DeleteObjects: Boolean): Boolean;
var
  TempBitmap: HBitmap;
begin
  Result := False;
  if (DC <> 0) and (CopyDC <> 0) and (CopyBitmap <> 0) then
  begin
    TempBitmap := CopyBitmap;
    CopyBitmap := SelectObject(DC, CopyBitmap);
    Result := BitBlt(DC, Left, Top, Width, Height, CopyDC, 0, 0, Rop);
    CopyBitmap := TempBitmap;
    if DeleteObjects then
    begin
      DeleteDC(CopyDC);
      DeleteObject(CopyBitmap);
    end;
  end;
end;


ID: 01908



Ниже приведен код, позволяющий скопировать панель. Для вырезания части изображения необходимо знать размеры и координаты вырезаемого прямоугольника, и заменить значения width, height, left и top, приведенные в коде, на реальные. Если вы действительно хотите вырезать, а не копировать область, то вам понадобиться ее залить с помощью вызова функции fillrect.

var
  BitMap: TBitmap;
begin
  BitMap := TBitMap.Create;
  BitMap.Height := BaseKeyPanel.Height;
  BitMap.Width := BaseKeyPanel.Width;
  BitBlt(BitMap.Canvas.Handle, 0 {Лево}, 0 {Top},
    BaseKeyPanel.Width, BaseKeyPanel.Height,
    GetDC(BaseKeyPanel.Handle), 0, 0, SRCCOPY);
  Clipboard.Assign(BitMap);
  BitMap.Free;
end;


Source: Взято с http://delphiworld.narod.ru
ID: 01909



Clipboard.Assign(Image1.Picture);




// Copy form1 as bitmap into the clipboard
procedure TForm1.Button1Click(Sender: TObject);
var
  imgWindow: TBitmap;
begin
  imgWindow := GetFormImage;
  try
    Clipboard.Assign(imgWindow);
  finally
    imgWindow.Free;
  end;
end;

// Save the bitmap to a file
// Das Bitmap in einer Datei speichern:

procedure TForm1.Button2Click(Sender: TObject);
var
  imgWindow: TBitmap;
begin
  imgWindow := TBitmap.Create;
  try
    imgWindow := Form1.GetFormImage;
    imgWindow.SaveToFile('c:\FormImage.bmp');
  finally
    imgWindow.Free;
  end;
end;


Source: Взято с сайта: http://www.swissdelphicenter.ch
ID: 01910


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


Source: Взято с сайта: http://www.swissdelphicenter.ch
ID: 01912