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

Некоторые функции для копирования и вставки 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;

---

Ниже приведен код, позволяющий скопировать панель. Для вырезания части изображения необходимо знать размеры и координаты вырезаемого прямоугольника, и заменить значения 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;

Взято с https://delphiworld.narod.ru

---

Clipboard.Assign(Image1.Picture);  

https://delphiworld.narod.ru/

DelphiWorld 6.0

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

Взято с сайта: https://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;
 
 

Взято с сайта: https://www.swissdelphicenter.ch