// Hiermit kann man zwischen seinen Projekten transparente PNG
// in die Zwischenablage stellen bzw. aus der Zwischenablage holen.
// Bedingung ist, dass in allen Projekten "CF_PNG" registriert
// wurde. Mit Fremdprogrammen funktioniert die Transparenz nicht.


// Getestet mit RS 10.4 unter Win11
 

uses Vcl.ClipBrd; 

var 
  PngFormat: Word; 
  ms: TMemoryStream; 
  P: Pointer; 
  hnd: THandle; 
 
procedure TForm1.FormCreate(Sender: TObject); 
begin 
  PngFormat := RegisterClipboardFormat('CF_PNG'); 
end; 
 
procedure insboard(mp: TPngImage); 
var 
  bm: TBitmap; 
begin 
  bm := TBitmap.create(mp.Width, mp.Height); 
  bm.canvas.draw(0, 0, mp); 
  ms := TMemoryStream.create; 
  try 
    mp.SaveToStream(ms); 
    hnd := GlobalAlloc(GMEM_DDESHARE, ms.Size); 
    P := GlobalLock(hnd); 
    try 
      ms.Seek(0, soBeginning); 
      ms.ReadBuffer(P^, ms.Size); 
    finally 
      GlobalUnlock(hnd); 
    end; 
    Clipboard.Open; 
    Clipboard.SetAsHandle(PngFormat, hnd); 
    Clipboard.assign(bm); 
    Clipboard.close; 
  finally 
    FreeAndNil(ms); 
    FreeAndNil(bm); 
  end; 
end; 
 
function ausboard(mp: TPngImage): Boolean; 
begin 
  Result := false; 
  if not assigned(mp) or not IsClipboardFormatAvailable(PngFormat) then 
    exit; 
  try 
    ms := TMemoryStream.create; 
    Clipboard.Open; 
    hnd := Clipboard.GetAsHandle(PngFormat); 
    Clipboard.close; 
    if hnd <> 0 then 
    begin 
      P := GlobalLock(hnd); 
      if P <> nil then 
      begin 
        try 
          ms.Write(P^, GlobalSize(hnd)); 
          Result := true; 
        finally 
          GlobalUnlock(hnd); 
        end; 
      end; 
    end; 
    if Result then 
    begin 
      ms.Seek(0, soBeginning); 
      mp.LoadFromStream(ms); 
    end; 
  except 
  end; 
  FreeAndNil(ms); 
end; 
 
 
// Beispielaufrufe 
 
// Transparente PNG in Zwischenablage stellen 
procedure TForm1.Button1Click(Sender: TObject); 
var 
  png: TPngImage; 
begin 
  png := TPngImage.create; 
  png.LoadFromFile('D:\Bilder\Jerry.png'); 
  insboard(png); 
  FreeAndNil(png); 
end; 
 
// PNG aus der Zwischenablage holen 
procedure TForm1.Button2Click(Sender: TObject); 
var 
  png: TPngImage; 
begin 
  png := TPngImage.create; 
  if ausboard(png) then 
    Image1.Picture.assign(png) 
  else 
    ShowMessage('Fehlgeschlagen'); 
  FreeAndNil(png); 
end; 
 
// Bitmap ohne Transparenz aus Zwischenablage 
procedure TForm1.Button3Click(Sender: TObject); 
begin 
  Image1.Picture.assign(Clipboard) 
end; 

Zugriffe seit 6.9.2001 auf Delphi-Ecke