Clipboard в Delphi: Изображение без потери альфа-канала

Для тестирования и изучения часто использую картинки из браузера. Но очень часто бывает так, что скопировал, вставил и вместо прозрачности вижу чёрный фон. А мне как раз нужна прозрачность, альфа-канал. Давайте разберёмся, почему так происходит и как это исправить.

Проблема не в изображении и не в браузере. Проблема в том, что VCL берёт из буфера обмена не тот формат. А тот формат лежит рядом, нетронутый. В буфере обмена Windows одновременно лежат несколько представлений одного и того же изображения. И среди них находится полноценный PNG с альфа-каналом. Но Delphi его не видит. Почему?

Содержание скрыть

Как VCL работает с изображением в буфере обмена

Что происходит при вызове TPicture.Assign

CF_BITMAP: формат без альфы

Как Windows синтезирует форматы

Можно ли спасти альфу

Что на самом деле лежит в буфере

Утилита: Содержимое буфера обмена

Имена стандартных форматов

Определяем размер данных

Перечисляем форматы

Запускаем и смотрим

Достаём PNG из буфера обмена

Извлекаем данные

Что здесь происходит

Тонкость: TPngImage косячит при масштабировании

Подключаем к интерфейсу

Результат

Достаём CF_DIBV5 из буфера обмена

Что внутри CF_DIBV5

Проблема с альфой

Порядок строк: bottom-up vs top-down

Код извлечения

Ключевые моменты

Последний рубеж: TPicture.Assign

Fallback через TPicture

Собираем каскад целиком

Готовый модуль: IP76.Imaging.Clipbrd

Копирование в буфер обмена

Листинг модуля IP76.Imaging.Clipbrd

Заключение

Скачать

Как VCL работает с изображением в буфере обмена

Типичный код вставки изображения из буфера обмена в Delphi выглядит так:

var
  Picture: TPicture;
begin
  Picture := TPicture.Create;
  try
    Picture.Assign(Clipboard);
    Image1.Picture := Picture;
  finally
    Picture.Free;
  end;
end;

var

Picture: TPicture;

begin

Picture := TPicture.Create;

try

Picture.Assign(Clipboard);

Image1.Picture := Picture;

finally

Picture.Free;

end;

Или ещё короче:

Image1.Picture.Assign(Clipboard);

1	Image1.Picture.Assign(Clipboard);

Просто, элегантно, но именно тут мы теряем альфа-канал. Чтобы понять почему, нужно заглянуть внутрь.

Что происходит при вызове TPicture.Assign

TPicture не работает с буфером обмена напрямую. Он опирается на реестр зарегистрированных графических форматов — внутренний список VCL, который связывает форматы буфера обмена с классами-наследниками TGraphic.

При старте приложения VCL автоматически регистрирует несколько связок (на самом деле это не прописано буквально, но по факту происходит именно при старте приложения):

// Vcl.Graphics
constructor TClipboardFormats.Create;
begin
  ...
  Add(CF_METAFILEPICT, TMetafile);
  Add(CF_ENHMETAFILE, TMetafile);
  Add(CF_BITMAP, TBitmap);
end;

// Vcl.Graphics

constructor TClipboardFormats.Create;

begin

...

Add(CF_METAFILEPICT, TMetafile);

Add(CF_ENHMETAFILE, TMetafile);

Add(CF_BITMAP, TBitmap);

end;

Когда вызывается TPicture.Assign(Clipboard), VCL перебирает этот список и ищет первый формат, который доступен в буфере. И если в буфере растр, то всегда находится CF_BITMAP, потому что другого Delphi не знает.

CF_BITMAP: формат без альфы

CF_BITMAP — это стандартный растровый формат буфера обмена, и именно его забирает VCL. Проблема в том, что CF_BITMAP представляет собой хэндл GDI-объекта (HBITMAP), а GDI исторически не знает, что такое альфа-канал. Четвёртый байт в 32-битном пикселе для GDI — просто мусор, пустое место для выравнивания. Но откуда CF_BITMAP вообще берётся, если приложение-источник его туда не положило? Тут вступает в игру механизм синтеза.

Как Windows синтезирует форматы

Когда приложение кладёт в буфер обмена изображение, оно обычно предоставляет один-два формата. Остальные Windows синтезирует автоматически. Например, если источник положил CF_DIB, Windows сам создаст CF_BITMAP. И наоборот.

Цепочка для VCL выглядит так:

VCL просит у буфера CF_BITMAP;
Если CF_BITMAP нет напрямую, Windows синтезирует его из CF_DIB или CF_DIBV5;
Создаётся HBITMAP, GDI-объект, привязанный к экранному контексту;
VCL оборачивает его в TBitmap.

Windows синтезирует CF_BITMAP из CF_DIB, сохраняя битность источника. Если приложение положило в буфер 32-битный DIB, то HBITMAP тоже будет 32-битный, и все четыре байта каждого пикселя скопируются как есть, включая четвёртый.

С точки зрения GDI четвёртый байт — это просто padding, выравнивание. GDI им не пользуется. Но физически он на месте. И если источник записал туда осмысленные значения альфа-канала, они доедут до TBitmap в целости.

Вот только VCL об этом не знает. После Assign(Clipboard) у TBitmap стоит AlphaFormat = afIgnored. Это означает, что при отрисовке четвёртый байт игнорируется. Картинка рисуется без прозрачности, но она хотя бы видна.

Можно ли спасти альфу

Можно попробовать. После вставки проходим по пикселям через ScanLine и проверяем четвёртый байт:

Bmp.Assign(Clipboard);

HasAlpha := False;
for Y := 0 to Bmp.Height - 1 do
begin
  Line := Bmp.ScanLine[Y];
  for X := 0 to Bmp.Width - 1 do
    if Line[X * 4 + 3] <> 0 then
    begin
      HasAlpha := True;
      Break;
    end;
  if HasAlpha then Break;
end;

if HasAlpha then
  Bmp.AlphaFormat := afDefined;

Bmp.Assign(Clipboard);

HasAlpha := False;

for Y := 0 to Bmp.Height - 1 do

begin

Line := Bmp.ScanLine[Y];

for X := 0 to Bmp.Width - 1 do

if Line[X * 4 + 3] <> 0 then

begin

HasAlpha := True;

Break;

end;

if HasAlpha then Break;

end;

if HasAlpha then

Bmp.AlphaFormat := afDefined;

Если нашли ненулевые значения, выставляем AlphaFormat := afDefined, и VCL начинает рисовать через AlphaBlend. Прозрачность работает.

Но результат сильно зависит от источника

Копируем из Paint.NET: Наш метод, описанный выше, работает, альфу определяем, получаем прозрачный фон.

Копируем из браузера (Chrome, Firefox, Edge): Пытаемся найти альфу, но альфа-байты все до единого нули. Не потому что изображение прозрачное, а потому что браузер просто не заполняет альфа-канал в этом формате. Он рассчитывает на то, что умный потребитель возьмёт PNG. Высказывание явно не в пользу Delphi.

Что мы видим после вставки: 32 бита на пиксель, цвета на месте, альфа сплошные нули. Наша проверка не находит ненулевых значений и AlphaFormat остаётся afIgnored. Картинка отрисовывается без прозрачности. Если вслепую выставим afDefined, то получим полностью невидимый прямоугольник, потому что альфа = 0 означает «полностью прозрачный».

И никакими манипуляциями с TBitmap это не исправить. Данных альфа-канала в CF_DIB физически нет. Их негде взять.

Получается, что стандартный путь VCL через CF_BITMAP — это лотерея. Иногда альфа доезжает, иногда нет. Зависит не от нашего кода, а от того, что источник положил в буфер.

Что на самом деле лежит в буфере

Картинка в буфере обмена находится не в единственном экземпляре. Это контейнер с множеством представлений одних и тех же данных. Когда браузер копирует изображение, он кладёт туда сразу несколько форматов, и среди них почти всегда есть полноценный PNG с альфа-каналом. VCL его не ищет, потому что формат PNG не зарегистрирован в списке TPicture.

Чтобы убедиться в этом, давайте напишем утилиту, которая покажет всё содержимое буфера.

Утилита: Содержимое буфера обмена

Напишем простую утилиту-просмотрщик буфера обмена. Она покажет все форматы, которые доступны в данный момент, их размер и тип. Интерфейс, служебные вещи описывать не буду, их можно скачать и подсмотреть в исходнике.

Имена стандартных форматов

Windows определяет 17 стандартных форматов буфера обмена с ID от 1 до 17. У них нет текстовых имён, которые можно получить через API, только числовые константы. Поэтому заведём табличку соответствий:

const
  StandardFormatNames: array[1..17] of record
    ID: Word;
    Name: string;
  end = (
    (ID: 1;  Name: 'CF_TEXT'),
    (ID: 2;  Name: 'CF_BITMAP'),
    (ID: 3;  Name: 'CF_METAFILEPICT'),
    (ID: 4;  Name: 'CF_SYLK'),
    (ID: 5;  Name: 'CF_DIF'),
    (ID: 6;  Name: 'CF_TIFF'),
    (ID: 7;  Name: 'CF_OEMTEXT'),
    (ID: 8;  Name: 'CF_DIB'),
    (ID: 9;  Name: 'CF_PALETTE'),
    (ID: 10; Name: 'CF_PENDATA'),
    (ID: 11; Name: 'CF_RIFF'),
    (ID: 12; Name: 'CF_WAVE'),
    (ID: 13; Name: 'CF_UNICODETEXT'),
    (ID: 14; Name: 'CF_ENHMETAFILE'),
    (ID: 15; Name: 'CF_HDROP'),
    (ID: 16; Name: 'CF_LOCALE'),
    (ID: 17; Name: 'CF_DIBV5')
  );

function GetStandardFormatName(Fmt: Cardinal): string;
var
  I: Integer;
begin
  Result := '';
  for I := Low(StandardFormatNames) to High(StandardFormatNames) do
    if StandardFormatNames[I].ID = Fmt then
      Exit(StandardFormatNames[I].Name);
end;

const

StandardFormatNames: array[1..17] of record

ID: Word;

Name: string;

end = (

(ID: 1; Name: 'CF_TEXT'),

(ID: 2; Name: 'CF_BITMAP'),

(ID: 3; Name: 'CF_METAFILEPICT'),

(ID: 4; Name: 'CF_SYLK'),

(ID: 5; Name: 'CF_DIF'),

(ID: 6; Name: 'CF_TIFF'),

(ID: 7; Name: 'CF_OEMTEXT'),

(ID: 8; Name: 'CF_DIB'),

(ID: 9; Name: 'CF_PALETTE'),

(ID: 10; Name: 'CF_PENDATA'),

(ID: 11; Name: 'CF_RIFF'),

(ID: 12; Name: 'CF_WAVE'),

(ID: 13; Name: 'CF_UNICODETEXT'),

(ID: 14; Name: 'CF_ENHMETAFILE'),

(ID: 15; Name: 'CF_HDROP'),

(ID: 16; Name: 'CF_LOCALE'),

(ID: 17; Name: 'CF_DIBV5')

);

function GetStandardFormatName(Fmt: Cardinal): string;

var

I: Integer;

begin

Result := '';

for I := Low(StandardFormatNames) to High(StandardFormatNames) do

if StandardFormatNames[I].ID = Fmt then

Exit(StandardFormatNames[I].Name);

end;

Для кастомных форматов (например, PNG или HTML Format) имя можно получить через GetClipboardFormatName.

Определяем размер данных

Не все форматы хранят данные как блок глобальной памяти. Некоторые возвращают GDI-хэндлы: для CF_BITMAP это HBITMAP, для CF_ENHMETAFILE — HENHMETAFILE, для CF_PALETTE — это HPALETTE. Вызов GlobalSize на таком хэндле приведёт к Access Violation.

Поэтому оборачиваем получение размера в безопасную функцию:

function SafeGetClipboardDataSize(Fmt: Cardinal): Cardinal;
var Handle: THandle;
begin
  Result := 0;

  // Эти форматы возвращают GDI-хэндлы, а не HGLOBAL
  if Fmt in [CF_BITMAP, CF_PALETTE, CF_ENHMETAFILE, CF_METAFILEPICT,
             CF_DSPBITMAP, CF_DSPENHMETAFILE, CF_DSPMETAFILEPICT] then
    Exit;

  Handle := GetClipboardData(Fmt);
  if Handle = 0 then
    Exit;

  try
    Result := GlobalSize(Handle);
  except
    Result := 0;
  end;
end;

function SafeGetClipboardDataSize(Fmt: Cardinal): Cardinal;

var Handle: THandle;

begin

Result := 0;

// Эти форматы возвращают GDI-хэндлы, а не HGLOBAL

if Fmt in [CF_BITMAP, CF_PALETTE, CF_ENHMETAFILE, CF_METAFILEPICT,

CF_DSPBITMAP, CF_DSPENHMETAFILE, CF_DSPMETAFILEPICT] then

Exit;

Handle := GetClipboardData(Fmt);

if Handle = 0 then

Exit;

try

Result := GlobalSize(Handle);

except

Result := 0;

end;

Примечание: В модуле (который представлен в листинге) мы не оборачиваем GlobalSize, потому что к этому моменту хэндл уже гарантированно валиден после успешного GetClipboardData. Здесь же нам нужно безопасное получение размера, потому что мы перебираем все форматы, содержащиеся в буфере обмена.

Перечисляем форматы

Вот основная процедура. Открываем буфер, перебираем все форматы через EnumClipboardFormats, для каждого определяем имя, размер и тип:

procedure TFmMain.EnumerateClipboard;
var
  Fmt: Cardinal;
  Buf: array[0..255] of Char;
  Info: PClipFormatInfo;
  Item: TListItem;
  Index: Integer;
  FormatType: string;
begin
  ClearFormatList;
  ListView1.Items.Clear;

  if not OpenClipboard(0) then
  begin
    Item := ListView1.Items.Add;
    Item.Caption := '!';
    Item.SubItems.Add('');
    Item.SubItems.Add('Failed to open clipboard');
    Exit;
  end;

  try
    Index := 0;
    Fmt := 0;
    repeat
      Fmt := EnumClipboardFormats(Fmt);
      if Fmt <> 0 then
      begin
        Inc(Index);

        New(Info);
        Info^.FormatID := Fmt;

        // Имя формата
        Info^.FormatName := GetStandardFormatName(Fmt);
        if Info^.FormatName = '' then
        begin
          FillChar(Buf, SizeOf(Buf), 0);
          if GetClipboardFormatName(Fmt, Buf, Length(Buf)) > 0 then
            Info^.FormatName := Buf
          else
            Info^.FormatName := Format('Unknown_%d', [Fmt]);
        end;

        // Размер
        Info^.DataSize := SafeGetClipboardDataSize(Fmt);

        // Определяем тип
        if Fmt = CF_BITMAP then
          FormatType := 'Bitmap (HBITMAP)'
        else if Fmt = CF_PALETTE then
          FormatType := 'Palette (HPALETTE)'
        else if Fmt = CF_ENHMETAFILE then
          FormatType := 'Metafile (HEMF)'
        else if Fmt = CF_METAFILEPICT then
          FormatType := 'Metafile (HMETA)'
        else if Info^.FormatName = 'PNG' then
          FormatType := 'Bitmap (PNG)'
        else if Fmt = CF_DIBV5 then
          FormatType := 'Bitmap (DIBv5)'
        else if Fmt = CF_DIB then
          FormatType := 'Bitmap (DIB)'
        else if Fmt in [CF_TEXT, CF_OEMTEXT, CF_UNICODETEXT] then
          FormatType := 'Text'
        else
          FormatType := 'Other';
        FFormatList.Add(Info);

        // Добавляем строку в ListView
        Item := ListView1.Items.Add;
        Item.Caption := IntToStr(Index);
        Item.SubItems.Add(IntToStr(Info^.FormatID));
        Item.SubItems.Add(Info^.FormatName);
        Item.SubItems.Add(FormatByteSize(Info^.DataSize));
        Item.SubItems.Add(FormatType);
        Item.Data := Info;  // связь строки с данными
      end;
    until Fmt = 0;
  finally
    CloseClipboard;
  end;
end;

procedure TFmMain.EnumerateClipboard;

var

Fmt: Cardinal;

Buf: array[0..255] of Char;

Info: PClipFormatInfo;

Item: TListItem;

Index: Integer;

FormatType: string;

begin

ClearFormatList;

ListView1.Items.Clear;

if not OpenClipboard(0) then

begin

Item := ListView1.Items.Add;

Item.Caption := '!';

Item.SubItems.Add('');

Item.SubItems.Add('Failed to open clipboard');

Exit;

end;

try

Index := 0;

Fmt := 0;

repeat

Fmt := EnumClipboardFormats(Fmt);

if Fmt <> 0 then

begin

Inc(Index);

New(Info);

Info^.FormatID := Fmt;

// Имя формата

Info^.FormatName := GetStandardFormatName(Fmt);

if Info^.FormatName = '' then

begin

FillChar(Buf, SizeOf(Buf), 0);

if GetClipboardFormatName(Fmt, Buf, Length(Buf)) > 0 then

Info^.FormatName := Buf

else

Info^.FormatName := Format('Unknown_%d', [Fmt]);

end;

// Размер

Info^.DataSize := SafeGetClipboardDataSize(Fmt);

// Определяем тип

if Fmt = CF_BITMAP then

FormatType := 'Bitmap (HBITMAP)'

else if Fmt = CF_PALETTE then

FormatType := 'Palette (HPALETTE)'

else if Fmt = CF_ENHMETAFILE then

FormatType := 'Metafile (HEMF)'

else if Fmt = CF_METAFILEPICT then

FormatType := 'Metafile (HMETA)'

else if Info^.FormatName = 'PNG' then

FormatType := 'Bitmap (PNG)'

else if Fmt = CF_DIBV5 then

FormatType := 'Bitmap (DIBv5)'

else if Fmt = CF_DIB then

FormatType := 'Bitmap (DIB)'

else if Fmt in [CF_TEXT, CF_OEMTEXT, CF_UNICODETEXT] then

FormatType := 'Text'

else

FormatType := 'Other';

FFormatList.Add(Info);

// Добавляем строку в ListView

Item := ListView1.Items.Add;

Item.Caption := IntToStr(Index);

Item.SubItems.Add(IntToStr(Info^.FormatID));

Item.SubItems.Add(Info^.FormatName);

Item.SubItems.Add(FormatByteSize(Info^.DataSize));

Item.SubItems.Add(FormatType);

Item.Data := Info; // связь строки с данными

end;

until Fmt = 0;

finally

CloseClipboard;

end;

Запускаем и смотрим

Копируем картинку с прозрачностью в браузере и жмём кнопку. Вот что мы видим:

Важный момент: EnumClipboardFormats перечисляет форматы в определённом порядке. Сначала идут те, которые приложение-источник реально положило в буфер. Затем те, которые Windows синтезировал автоматически. Синтез работает по группам: если источник положил CF_DIB, Windows автоматически создаёт CF_BITMAP и CF_DIBV5. И наоборот.

В нашем примере браузер положил кучу всего вместе с картинкой. Нас интересуют форматы: PNG и CF_DIBV5. CF_DIB и CF_BITMAP — синтезированы Windows.

Главное, что мы видим полноценный PNG-файл, возможно с альфа-каналом, размером чуть больше 383 KB. Именно его VCL проигнорирует, схватив вместо этого синтезированный CF_BITMAP без прозрачности.

Сейчас мы достанем PNG оттуда сами.

Достаём PNG из буфера обмена

Формат PNG — это кастомный формат буфера обмена. Он не входит в список стандартных (1–17), а регистрируется приложением-источником через RegisterClipboardFormat(‘PNG’). У него нет фиксированного ID, он будет разным при каждой загрузке Windows. Поэтому первым делом нам нужно узнать его ID:

var
  CF_PNG: Cardinal;

// В FormCreate (или в initialization):
CF_PNG := RegisterClipboardFormat('PNG');

var

CF_PNG: Cardinal;

// В FormCreate (или в initialization):

CF_PNG := RegisterClipboardFormat('PNG');

Несмотря на слово «Register», функция не создаёт новый формат, если он уже зарегистрирован. Она просто возвращает его ID. Если хром его зарегистрировал ранее, мы получим тот же идентификатор, что и у браузера.

Извлекаем данные

Данные кастомного формата лежат в буфере как блок глобальной памяти. Это буквально содержимое PNG-файла, байт в байт. Нужно его скопировать в поток и скормить TPngImage:

function TryLoadPNG(out Graphic: TGraphic): Boolean;
var
  DataHandle: THandle;
  DataPtr: Pointer;
  DataSize: Cardinal;
  Stream: TMemoryStream;
  Png: TPngImage;
begin
  Result := False;
  Graphic := nil;

  // Проверяем, есть ли PNG в буфере
  if not IsClipboardFormatAvailable(CF_PNG) then
    Exit;

  if not OpenClipboard(0) then
    Exit;

  try
    // Получаем хэндл блока данных
    DataHandle := GetClipboardData(CF_PNG);
    if DataHandle = 0 then
      Exit;

    // Узнаём размер
    DataSize := GlobalSize(DataHandle);
    if DataSize = 0 then
      Exit;

    // Блокируем память и получаем указатель
    DataPtr := GlobalLock(DataHandle);
    if DataPtr = nil then
      Exit;

    try
      // Копируем данные в поток
      Stream := TMemoryStream.Create;
      try
        Stream.WriteBuffer(DataPtr^, DataSize);
        Stream.Position := 0;

        // Загружаем как PNG
        Png := TPngImage.Create;
        try
          Png.LoadFromStream(Stream);
          Graphic := Png;
          Result := True;
        except
          Png.Free;
        end;
      finally
        Stream.Free;
      end;
    finally
      GlobalUnlock(DataHandle);
    end;
  finally
    CloseClipboard;
  end;
end;

function TryLoadPNG(out Graphic: TGraphic): Boolean;

var

DataHandle: THandle;

DataPtr: Pointer;

DataSize: Cardinal;

Stream: TMemoryStream;

Png: TPngImage;

begin

Result := False;

Graphic := nil;

// Проверяем, есть ли PNG в буфере

if not IsClipboardFormatAvailable(CF_PNG) then

Exit;

if not OpenClipboard(0) then

Exit;

try

// Получаем хэндл блока данных

DataHandle := GetClipboardData(CF_PNG);

if DataHandle = 0 then

Exit;

// Узнаём размер

DataSize := GlobalSize(DataHandle);

if DataSize = 0 then

Exit;

// Блокируем память и получаем указатель

DataPtr := GlobalLock(DataHandle);

if DataPtr = nil then

Exit;

try

// Копируем данные в поток

Stream := TMemoryStream.Create;

try

Stream.WriteBuffer(DataPtr^, DataSize);

Stream.Position := 0;

// Загружаем как PNG

Png := TPngImage.Create;

try

Png.LoadFromStream(Stream);

Graphic := Png;

Result := True;

except

Png.Free;

end;

finally

Stream.Free;

end;

finally

GlobalUnlock(DataHandle);

end;

finally

CloseClipboard;

end;

Что здесь происходит

Цепочка вызовов повторяет стандартный паттерн работы с буфером обмена через WinAPI:

IsClipboardFormatAvailable — быстрая проверка без открытия буфера;
OpenClipboard(0) — захватываем буфер (0 = без привязки к окну);
GetClipboardData — получаем хэндл блока памяти;
GlobalLock — превращаем хэндл в указатель на данные;
Копируем в TMemoryStream, загружаем в TPngImage;
GlobalUnlock + CloseClipboard — обязательно освобождаем.

Можно открыть Vcl.Clipbrd и подсмотреть, как строится работа с буфером обмена в Delphi. Там будет ровно тот же шаблон.

Важно: данные из GetClipboardData нельзя освобождать, они принадлежат буферу обмена. Мы их только читаем и копируем.

Тонкость: TPngImage косячит при масштабировании

В предыдущей статье мы разобрали случай, когда TPngImage отображает себя с некоторым смещением при масштабировании. В той же статье сделали вывод, что самое простое — это получать из него TBitmap и отображать уже его.

Поэтому будем конвертировать TPngImage в TBitmap перед отображением:

function TryLoadPNGAsBitmap(out Graphic: TGraphic): Boolean;
var Png: TGraphic;
begin
  Result := False;
  Graphic := nil;

  if not TryLoadPNG(Png) then
    exit;

  try
    Graphic := TBitmap.Create;
    Graphic.Assign(Png);
    Result := True;
  finally
    Png.Free;
  end;
end;

function TryLoadPNGAsBitmap(out Graphic: TGraphic): Boolean;

var Png: TGraphic;

begin

Result := False;

Graphic := nil;

if not TryLoadPNG(Png) then

exit;

try

Graphic := TBitmap.Create;

Graphic.Assign(Png);

Result := True;

finally

Png.Free;

end;

TPngImage.AssignTo создаёт 32-битный TBitmap с AlphaFormat := afDefined. При этом альфа-канал сохраняется, а масштабирование берёт на себя WinAPI.

Подключаем к интерфейсу

При клике на строку PNG в нашем ListView вызываем извлечение и показываем результат:

procedure TFmMain.ListView1SelectItem(Sender: TObject; Item: TListItem;
  Selected: Boolean);
var
  Info: PClipFormatInfo;
  Graphic: TGraphic;
begin
  if not Selected then
    Exit;
  if Item.Data = nil then
    Exit;

  Info := PClipFormatInfo(Item.Data);

  // Пока обрабатываем только PNG
  if (Info^.FormatName = 'PNG') and TryLoadPNGAsBitmap(Graphic) then
  begin
    try
      Image1.Picture.Graphic := Graphic;
      ShowStatus(Format('PNG | %dx%d', [Graphic.Width, Graphic.Height]));
    finally
      Graphic.Free;
    end;
  end
  else
    ShowStatus(Format('Format "%s" — extraction not yet implemented',
      [Info^.FormatName]));
end;

procedure TFmMain.ListView1SelectItem(Sender: TObject; Item: TListItem;

Selected: Boolean);

var

Info: PClipFormatInfo;

Graphic: TGraphic;

begin

if not Selected then

Exit;

if Item.Data = nil then

Exit;

Info := PClipFormatInfo(Item.Data);

// Пока обрабатываем только PNG

if (Info^.FormatName = 'PNG') and TryLoadPNGAsBitmap(Graphic) then

begin

try

Image1.Picture.Graphic := Graphic;

ShowStatus(Format('PNG | %dx%d', [Graphic.Width, Graphic.Height]));

finally

Graphic.Free;

end;

end

else

ShowStatus(Format('Format "%s" — extraction not yet implemented',

[Info^.FormatName]));

end;

Результат

Копируем PNG с прозрачностью из браузера, жмём «Refresh», кликаем на строку PNG и видим картинку с альфа-каналом. Прозрачные области отображаются корректно, без чёрного фона.

Всё, что нужно было, это попросить у буфера правильный формат.

В следующем разделе добавим запасной вариант — извлечение через CF_DIBV5, на случай если источник не положил PNG.

Достаём CF_DIBV5 из буфера обмена

Не все приложения кладут в буфер формат PNG. Но многие кладут CF_DIBV5. Это расширенный формат DIB с заголовком BITMAPV5HEADER, который умеет описывать 32-битные пиксели с альфа-каналом. VCL его не обрабатывает, но мы можем разобрать вручную.

Что внутри CF_DIBV5

Данные CF_DIBV5 представляют собой непрерывный блок памяти. Сначала идёт заголовок BITMAPV5HEADER размером 124 байта (SizeOf(BITMAPV5HEADER)), сразу за ним — пиксельные данные.

Формат пиксельных данных зависит от параметра структуры bV5BitCount. Нас интересует только 32-битный вариант — именно он содержит альфа-канал. При bV5BitCount = 32 каждый пиксель занимает 4 байта: Blue, Green, Red, Alpha. Знакомая структура, если работали с TBitmap.PixelFormat = pf32bit. Всё остальное мы отбрасываем — без альфа-канала нет смысла возиться с CF_DIBV5, проще отдать картинку стандартному обработчику CF_DIB.

Проблема с альфой

Как мы выяснили ранее, недостающие форматы Windows синтезирует автоматически. Помимо PNG, браузер кладёт изображение в одном из растровых форматов (CF_DIB или CF_DIBV5), остальные Windows синтезирует автоматически. Но при синтезе альфа-канал теряется — все альфа-байты равны нулю.

Если мы установим AlphaFormat := afDefined, то альфа = 0 будет означать «полностью прозрачный» и мы получим полностью прозрачную, то есть абсолютно невидимую, картинку.

Поэтому нужна проверка: проходим по всем пикселям и смотрим, есть ли хоть одно ненулевое значение альфы. Если нет — считаем, что альфа-канал не заполнен, и принудительно выставляем все байты в 255 (полная непрозрачность).

Порядок строк: bottom-up vs top-down

Ещё один подводный камень. DIB хранит строки пикселей в порядке снизу вверх (bottom-up) — так исторически сложилось. Признак — положительное значение bV5Height. Если bV5Height отрицательное — строки идут сверху вниз (top-down).

TBitmap.ScanLine[0] — это всегда верхняя строка, как бы данные внутри битмапа на самом деле не располагались. Поэтому при чтении bottom-up нужно перевернуть порядок.

Код извлечения

function TryLoadDIBV5(out Graphic: TGraphic): Boolean;
var
  DataHandle: THandle;
  DataPtr: Pointer;
  Header: PBitmapV5Header;
  Bits: PByte;
  Bmp: TBitmap;
  Y, X: Integer;
  SrcLine, DstLine: PByteArray;
  SrcLineWidth: Integer;
  HasRealAlpha: Boolean;
begin
  Result := False;
  Graphic := nil;

  if not IsClipboardFormatAvailable(CF_DIBV5) then
    Exit;

  if not OpenClipboard(0) then
    Exit;

  try
    DataHandle := GetClipboardData(CF_DIBV5);
    if DataHandle = 0 then
      Exit;

    DataPtr := GlobalLock(DataHandle);
    if DataPtr = nil then
      Exit;

    try
      Header := PBitmapV5Header(DataPtr);

      // Поддерживаем только 32-бит BGRA
      if Header^.bV5BitCount <> 32 then
        Exit;
      if Header^.bV5Compression > BI_BITFIELDS then
        Exit;

      // Пиксели начинаются сразу за заголовком
      Bits := PByte(DataPtr) + Header^.bV5Size;

      // Ширина строки в байтах (32-бит, уже выровнена на 4)
      SrcLineWidth := Integer(Header^.bV5Width) * 4;

      Bmp := TBitmap.Create;
      try
        Bmp.PixelFormat := pf32bit;
        Bmp.SetSize(Header^.bV5Width, Abs(Header^.bV5Height));

        // Копируем пиксели и одновременно проверяем альфу
        HasRealAlpha := False;

        for Y := 0 to Bmp.Height - 1 do
        begin
          // Определяем строку-источник с учётом порядка
          if Header^.bV5Height > 0 then
            // bottom-up: последняя строка DIB = первая строка TBitmap
            SrcLine := PByteArray(Bits + (Bmp.Height - 1 - Y) * SrcLineWidth)
          else
            // top-down: порядок совпадает
            SrcLine := PByteArray(Bits + Y * SrcLineWidth);

          // Копируем строку целиком
          DstLine := Bmp.ScanLine[Y];
          Move(SrcLine^, DstLine^, SrcLineWidth);

          // Проверяем альфа-байты (каждый 4-й в BGRA)
          if not HasRealAlpha then
            for X := 0 to Bmp.Width - 1 do
              if DstLine^[X * 4 + 3] <> 0 then
              begin
                HasRealAlpha := True;
                Break;
              end;
        end;

        // Решаем, что делать с альфой
        if HasRealAlpha then
          // Альфа настоящая — включаем прозрачность
          Bmp.AlphaFormat := afDefined
        else
        begin
          // Альфа пустая — заполняем 255, иначе картинка будет невидимой
          for Y := 0 to Bmp.Height - 1 do
          begin
            DstLine := Bmp.ScanLine[Y];
            for X := 0 to Bmp.Width - 1 do
              DstLine^[X * 4 + 3] := 255;
          end;
          Bmp.AlphaFormat := afIgnored;
        end;

        Graphic := Bmp;
        Result := True;
      except
        Bmp.Free;
      end;
    finally
      GlobalUnlock(DataHandle);
    end;
  finally
    CloseClipboard;
  end;
end;

100

101

102

103

104

105

function TryLoadDIBV5(out Graphic: TGraphic): Boolean;

var

DataHandle: THandle;

DataPtr: Pointer;

Header: PBitmapV5Header;

Bits: PByte;

Bmp: TBitmap;

Y, X: Integer;

SrcLine, DstLine: PByteArray;

SrcLineWidth: Integer;

HasRealAlpha: Boolean;

begin

Result := False;

Graphic := nil;

if not IsClipboardFormatAvailable(CF_DIBV5) then

Exit;

if not OpenClipboard(0) then

Exit;

try

DataHandle := GetClipboardData(CF_DIBV5);

if DataHandle = 0 then

Exit;

DataPtr := GlobalLock(DataHandle);

if DataPtr = nil then

Exit;

try

Header := PBitmapV5Header(DataPtr);

// Поддерживаем только 32-бит BGRA

if Header^.bV5BitCount <> 32 then

Exit;

if Header^.bV5Compression > BI_BITFIELDS then

Exit;

// Пиксели начинаются сразу за заголовком

Bits := PByte(DataPtr) + Header^.bV5Size;

// Ширина строки в байтах (32-бит, уже выровнена на 4)

SrcLineWidth := Integer(Header^.bV5Width) * 4;

Bmp := TBitmap.Create;

try

Bmp.PixelFormat := pf32bit;

Bmp.SetSize(Header^.bV5Width, Abs(Header^.bV5Height));

// Копируем пиксели и одновременно проверяем альфу

HasRealAlpha := False;

for Y := 0 to Bmp.Height - 1 do

begin

// Определяем строку-источник с учётом порядка

if Header^.bV5Height > 0 then

// bottom-up: последняя строка DIB = первая строка TBitmap

SrcLine := PByteArray(Bits + (Bmp.Height - 1 - Y) * SrcLineWidth)

else

// top-down: порядок совпадает

SrcLine := PByteArray(Bits + Y * SrcLineWidth);

// Копируем строку целиком

DstLine := Bmp.ScanLine[Y];

Move(SrcLine^, DstLine^, SrcLineWidth);

// Проверяем альфа-байты (каждый 4-й в BGRA)

if not HasRealAlpha then

for X := 0 to Bmp.Width - 1 do

if DstLine^[X * 4 + 3] <> 0 then

begin

HasRealAlpha := True;

Break;

end;

// Решаем, что делать с альфой

if HasRealAlpha then

// Альфа настоящая — включаем прозрачность

Bmp.AlphaFormat := afDefined

else

begin

// Альфа пустая — заполняем 255, иначе картинка будет невидимой

for Y := 0 to Bmp.Height - 1 do

begin

DstLine := Bmp.ScanLine[Y];

for X := 0 to Bmp.Width - 1 do

DstLine^[X * 4 + 3] := 255;

end;

Bmp.AlphaFormat := afIgnored;

end;

Graphic := Bmp;

Result := True;

except

Bmp.Free;

end;

finally

GlobalUnlock(DataHandle);

end;

finally

CloseClipboard;

end;

Ключевые моменты

Проверка bV5BitCount <> 32: нас интересует только 32-битный формат, где есть место для альфа-байта. 24-битный CF_DIBV5 обрабатывать смысла нет, потому что там альфы точно нет.

Проверка bV5Compression > BI_BITFIELDS: мы поддерживаем BI_RGB (0) и BI_BITFIELDS (3). Экзотические варианты вроде JPEG/PNG-сжатия внутри DIB пропускаем.

Указатель на пиксели: PByte(DataPtr) + Header^.bV5Size. Заголовок BITMAPV5HEADER имеет фиксированный размер 124 байта, записанный в поле bV5Size. Пиксели идут сразу за ним.

Проверка альфы: один проход по всем пикселям. Как только нашли хоть одно ненулевое значение, то выставляем HasRealAlpha := True, и дальше можно не проверять (но копировать строки всё равно нужно).

Убеждаемся, что браузер кладёт CF_DIBV5 без альфы. Поэтому картинки, скопированные из браузера и вставленные с помощью VCL, не содержат данные альфа-канала.

Теперь мы можем убедиться, что Paint.NET укладывает в буфер обмена CF_DIBV5 с честным альфа-каналом, который синтезируется потом в CF_BITMAP с переносом и 4-го байта прозрачности.

В следующем разделе добавим последний рубеж обороны — fallback через стандартный TPicture.Assign, чтобы хоть что-то показать, даже если ни PNG, ни CF_DIBV5 не сработали.

Последний рубеж: TPicture.Assign

Если в буфере нет ни PNG, ни CF_DIBV5 с настоящей альфой, это ещё не повод сдаваться. В буфере может лежать обычный CF_BITMAP, метафайл или что-то ещё, что VCL умеет обрабатывать штатно. Пусть без прозрачности — но хотя бы картинка будет.

Fallback через TPicture

function TryLoadTPicture(out Graphic: TGraphic): Boolean;
var
  Pic: TPicture;
begin
  Result := False;
  Graphic := nil;

  Pic := TPicture.Create;
  try
    try
      Pic.Assign(Clipboard);
      if Pic.Graphic <> nil then
      begin
        // Создаём копию — Pic владеет своим Graphic
        // и уничтожит его в деструкторе
        Graphic := TGraphicClass(Pic.Graphic.ClassType).Create;
        Graphic.Assign(Pic.Graphic);
        Result := True;
      end;
    except
      FreeAndNil(Graphic);
    end;
  finally
    Pic.Free;
  end;
end;

function TryLoadTPicture(out Graphic: TGraphic): Boolean;

var

Pic: TPicture;

begin

Result := False;

Graphic := nil;

Pic := TPicture.Create;

try

Pic.Assign(Clipboard);

if Pic.Graphic <> nil then

begin

// Создаём копию — Pic владеет своим Graphic

// и уничтожит его в деструкторе

Graphic := TGraphicClass(Pic.Graphic.ClassType).Create;

Graphic.Assign(Pic.Graphic);

Result := True;

end;

except

FreeAndNil(Graphic);

end;

finally

Pic.Free;

end;

Единственная тонкость — нельзя вернуть Pic.Graphic напрямую. Объект TPicture владеет своим Graphic и уничтожит его при Pic.Free. Поэтому создаём копию того же класса через TGraphicClass(Pic.Graphic.ClassType).Create и делаем Assign.

Собираем каскад целиком

Теперь у нас три метода извлечения, выстроенных по приоритету — от лучшего к худшему:

PNG: полный альфа-канал, идеальное качество
CF_DIBV5: альфа возможна, если источник её заполнил
TPicture: стандартный путь VCL, без альфы, но хоть что-то

Обновляем обработчик выбора в ListView:

procedure TFmMain.ListView1SelectItem(Sender: TObject; Item: TListItem;
  Selected: Boolean);
var
  Info: PClipFormatInfo;
  Graphic: TGraphic;
  Method: string;
  AlphaInfo: string;
begin
  if not Selected then Exit;
  if Item.Data = nil then Exit;

  Info := PClipFormatInfo(Item.Data);
  Graphic := nil;

  // Каскад: PNG - CF_DIBV5 - TPicture
  if (Info^.FormatName = 'PNG') and TryLoadPNG(Graphic) then
    Method := 'PNG'
  else if (Info^.FormatID = CF_DIBV5) and TryLoadDIBV5(Graphic) then
    Method := 'CF_DIBV5'
  else if TryLoadTPicture(Graphic) then
    Method := 'TPicture (fallback)'
  else
  begin
    ShowStatus(Format('Format "%s" — failed to extract image',
      [Info^.FormatName]));
    Image1.Picture.Graphic := nil;
    Exit;
  end;

  try
    Image1.Picture.Graphic := Graphic;

    // Определяем информацию об альфе
    if Graphic is TPngImage then
    begin
      case TPngImage(Graphic).Header.ColorType of
        COLOR_RGBALPHA:       AlphaInfo := 'RGBA (alpha present)';
        COLOR_GRAYSCALEALPHA: AlphaInfo := 'GrayAlpha (alpha present)';
      else
        AlphaInfo := 'no alpha';
      end;
    end
    else if Graphic is TBitmap then
    begin
      case TBitmap(Graphic).AlphaFormat of
        afDefined: AlphaInfo := '32bit (alpha present)';
        afIgnored: AlphaInfo := '32bit (alpha empty)';
      else
        AlphaInfo := Format('%dbit', [GetDeviceCaps(0, BITSPIXEL)]);
      end;
    end
    else
      AlphaInfo := Graphic.ClassName;

    ShowStatus(Format('%s | %dx%d | %s',
      [Method, Graphic.Width, Graphic.Height, AlphaInfo]));
  finally
    Graphic.Free;
  end;
end;

procedure TFmMain.ListView1SelectItem(Sender: TObject; Item: TListItem;

Selected: Boolean);

var

Info: PClipFormatInfo;

Graphic: TGraphic;

Method: string;

AlphaInfo: string;

begin

if not Selected then Exit;

if Item.Data = nil then Exit;

Info := PClipFormatInfo(Item.Data);

Graphic := nil;

// Каскад: PNG - CF_DIBV5 - TPicture

if (Info^.FormatName = 'PNG') and TryLoadPNG(Graphic) then

Method := 'PNG'

else if (Info^.FormatID = CF_DIBV5) and TryLoadDIBV5(Graphic) then

Method := 'CF_DIBV5'

else if TryLoadTPicture(Graphic) then

Method := 'TPicture (fallback)'

else

begin

ShowStatus(Format('Format "%s" — failed to extract image',

[Info^.FormatName]));

Image1.Picture.Graphic := nil;

Exit;

end;

try

Image1.Picture.Graphic := Graphic;

// Определяем информацию об альфе

if Graphic is TPngImage then

begin

case TPngImage(Graphic).Header.ColorType of

COLOR_RGBALPHA: AlphaInfo := 'RGBA (alpha present)';

COLOR_GRAYSCALEALPHA: AlphaInfo := 'GrayAlpha (alpha present)';

else

AlphaInfo := 'no alpha';

end;

end

else if Graphic is TBitmap then

begin

case TBitmap(Graphic).AlphaFormat of

afDefined: AlphaInfo := '32bit (alpha present)';

afIgnored: AlphaInfo := '32bit (alpha empty)';

else

AlphaInfo := Format('%dbit', [GetDeviceCaps(0, BITSPIXEL)]);

end;

end

else

AlphaInfo := Graphic.ClassName;

ShowStatus(Format('%s | %dx%d | %s',

[Method, Graphic.Width, Graphic.Height, AlphaInfo]));

finally

Graphic.Free;

end;

Так сразу видно — удалось ли сохранить прозрачность, и каким способом.

Готовый модуль: IP76.Imaging.Clipbrd

Всё, что мы разобрали по частям: каскадную загрузку PNG — CF_DIBV5 — VCL, ручной разбор альфа-канала, проверку пустой альфы, собрал в один модуль. Подключаете к проекту и заменяете стандартную вставку одной функцией:

uses
  IP76.Imaging.Clipbrd;

var
  Graphic: TGraphic;
begin
  if TryLoadGraphicFromClipboard(Graphic) then
  try
    Image1.Picture.Graphic := Graphic;
  finally
    Graphic.Free;
  end;
end;

uses

IP76.Imaging.Clipbrd;

var

Graphic: TGraphic;

begin

if TryLoadGraphicFromClipboard(Graphic) then

try

Image1.Picture.Graphic := Graphic;

finally

Graphic.Free;

end;

TryLoadGraphicFromClipboard сама пробует форматы в порядке приоритета:

PNG: полный альфа-канал, лучший вариант;
CF_DIBV5: ручной разбор 32-битных пикселей, альфа сохраняется, если источник её заполнил;
VCL fallback: стандартный TPicture.Assign(Clipboard), без альфы, но хоть что-то.

Функция возвращает TGraphic, который должен освободить вызывающий. На практике сейчас это всегда TBitmap, и был соблазн так и написать в сигнатуре. Но оставил TGraphic по нескольким причинам. Во-первых, симметрия: TrySaveGraphicToClipboard (следующий раздел) принимает TGraphic, логично, чтобы загрузка возвращала тот же тип. Во-вторых, опыт подсказывает, что ограничиваться TBitmap не стоит. Завтра может появиться формат, для которого разумнее вернуть другой класс (например, TMetafile из CF_ENHMETAFILE), и сигнатуру не придётся ломать.

Если нужен контроль, можно вызывать каждый уровень отдельно: TryLoadPNG, TryLoadDIBV5, TryLoadVCL.

Копирование в буфер обмена

Обратная задача — положить изображение в буфер так, чтобы другие приложения получили альфа-канал. Стандартный VCL кладёт только CF_BITMAP, и получатель оказывается в той же ситуации, что и мы в начале статьи.

Модуль решает это симметрично:

uses
  IP76.Imaging.Clipbrd;

// Копируем содержимое TImage в буфер с альфой
TrySaveGraphicToClipboard(Image1.Picture.Graphic);

uses

IP76.Imaging.Clipbrd;

// Копируем содержимое TImage в буфер с альфой

TrySaveGraphicToClipboard(Image1.Picture.Graphic);

TrySaveGraphicToClipboard кладёт в буфер сразу два формата:

PNG: для приложений, которые его понимают (браузеры, Photoshop, GIMP, Paint.NET);
CF_DIBV5: для приложений, читающих DIB с альфой, но не читающих PNG.

И, если не получилось с обоими, кладёт изображение через VCL: Clipboard.Assign(Graphic).

Остальное Windows синтезирует сам: CF_DIB и CF_BITMAP появятся в буфере автоматически. Так что приложения без поддержки альфы тоже получат картинку — просто без прозрачности.

Входной TGraphic может быть любым — TBitmap, TPngImage, даже TMetafile. Модуль сам конвертирует его в 32-битный битмап с альфой перед записью. Если у исходного изображения нет альфа-канала, все пиксели получат альфу 255 (полная непрозрачность).

Как и при загрузке, отдельные функции доступны напрямую: TrySavePNG, TrySaveDIBV5, TrySaveVCL.

Листинг модуля IP76.Imaging.Clipbrd

Модуль, как мне кажется, очень подробно прокомментирован. Если всё равно останутся вопросы, обращайтесь, либо в комментариях к статье, либо в телеге, обязательно отвечу.

IP76.Imaging.Clipbrd

//******************************************************************************
//  Project: IP76.RU
//  Created: 2026-02-12
//  Article: https://ip76.ru/clipbrd-alpha/
//  Описание: Модуль для обмена изображениями через буфер обмена
//    без потери альфа-канала
//------------------------------------------------------------------------------
//  Загрузка из буфера:
//    function TryLoadGraphicFromClipboard(out Graphic: TGraphic): Boolean;
//    Стандартный VCL (TPicture/TClipboard) теряет альфа-канал при вставке
//    Функция реализует каскадную загрузку: сначала пробуем PNG,
//    затем CF_DIBV5 с ручным разбором альфы, и только потом,
//    если ничего не сработало, используем стандартный механизм VCL
//------------------------------------------------------------------------------
//  Сохранение в буфер:
//    function TrySaveGraphicToClipboard(Graphic: TGraphic): Boolean;
//    Стандартный VCL кладёт только CF_BITMAP, получатель может не увидеть альфу
//    Функция кладёт сразу PNG и CF_DIBV5 с альфа-каналом
//    CF_DIB и CF_BITMAP Windows синтезирует автоматически
//******************************************************************************

unit IP76.Imaging.Clipbrd;

interface

uses
  Winapi.Windows,
  System.SysUtils, System.Classes,
  Vcl.Graphics;

// Каскадная загрузка изображения из буфера обмена
// Пробует форматы в порядке приоритета: PNG->CF_DIBV5->стандартный VCL
// Возвращает True, если удалось загрузить
// Graphic создаётся внутри - вызывающий отвечает за освобождение
function TryLoadGraphicFromClipboard(out Graphic: TGraphic): Boolean;

// Загрузка PNG из буфера обмена
// Многие приложения (браузеры, графические редакторы) кладут PNG -
// это лучший вариант, альфа-канал сохраняется как есть
// Результат конвертируется в TBitmap, чтобы избежать проблем
// с масштабированием в TPngImage.Draw
function TryLoadPNG(out Graphic: TGraphic): Boolean;

// Загрузка CF_DIBV5 с ручным разбором альфа-канала
// Формат CF_DIBV5 поддерживает 32-битные пиксели с альфой,
// но VCL его не обрабатывает, разбираем вручную
// Если альфа-канал пуст (все нули), то заполняем 255
function TryLoadDIBV5(out Graphic: TGraphic): Boolean;

// Загрузка через стандартный механизм VCL (TClipboard.Assign)
function TryLoadVCL(out Graphic: TGraphic): Boolean;

// Каскадное копирование изображения в буфер обмена
// Кладёт PNG + CF_DIBV5 для приложений с поддержкой альфы,
// CF_DIB/CF_BITMAP Windows синтезирует автоматически
// Возвращает True, если удалось положить хотя бы один формат
function TrySaveGraphicToClipboard(Graphic: TGraphic): Boolean;

// Кладёт изображение в буфер как PNG
// Для приложений, понимающих PNG (браузеры, Photoshop, GIMP)
function TrySavePNG(Graphic: TGraphic): Boolean;

// Кладёт изображение в буфер как CF_DIBV5 с альфа-каналом
// Для приложений, читающих DIB с альфой, но не читающих PNG
function TrySaveDIBV5(Graphic: TGraphic): Boolean;

// Кладёт изображение в буфер через стандартный механизм VCL
function TrySaveVCL(Graphic: TGraphic): Boolean;

implementation

uses
  Vcl.Clipbrd, Vcl.Imaging.PngImage;

var
  CF_PNG: Word;

{$Region 'Вспомогательные функции (загрузка из буфера)'}

// Читает сырые данные формата из буфера обмена в поток
// Возвращает nil, если формат отсутствует или данные пусты
function GetClipboardStream(AFormat: Word): TMemoryStream;
var H: THandle; Ptr: Pointer; Size: NativeUInt;
begin
  Result := nil;

  Clipboard.Open;
  try
    H := Clipboard.GetAsHandle(AFormat);
    if H = 0 then
      exit;

    Ptr := GlobalLock(H);
    if Ptr = nil then
      exit;

    try
      Size := GlobalSize(H);
      if Size = 0 then
        exit;

      Result := TMemoryStream.Create;
      Result.WriteBuffer(Ptr^, Size);
      Result.Position := 0;
    finally
      GlobalUnlock(H);
    end;
  finally
    Clipboard.Close;
  end;
end;

// Проверяет, есть ли в массиве пикселей хотя бы одно ненулевое значение альфы
// Если все альфа-байты нулевые, значит альфа-канал не заполнен
function HasAlpha(Bits: PByte; PixelCount: Integer): Boolean;
var I: Integer; P: PByte;
begin
  Result := False;
  P := Bits;
  Inc(P, 3); // встаём на первый альфа-байт (тут BGRA => смещение 3)

  for I := 0 to PixelCount - 1 do
  begin
    if P^ <> 0 then
      exit(True);
    Inc(P, 4);
  end;
end;

// Принудительно заполняет альфа-канал значением 255
procedure FillAlpha(Bits: PByte; PixelCount: Integer);
var I: Integer; P: PByte;
begin
  P := Bits;
  Inc(P, 3);

  for I := 0 to PixelCount - 1 do
  begin
    P^ := 255;
    Inc(P, 4);
  end;
end;

{$EndRegion}

{$Region 'Загрузка из буфера обмена'}

// Загрузка PNG
function TryLoadPNG(out Graphic: TGraphic): Boolean;
var S: TMemoryStream; Png: TPngImage; Bmp: TBitmap;
begin
  Result := False;
  Graphic := nil;

  if CF_PNG = 0 then
    exit;

  S := GetClipboardStream(CF_PNG);
  if S = nil then
    exit;

  Png := TPngImage.Create;
  try
    try
      Png.LoadFromStream(S);
    finally
      S.Free;
    end;

    // Конвертируем в TBitmap.
    // TPngImage.Draw при масштабировании слегка глючит:
    //   https://ip76.ru/tpngimage-stretch-bug/
    // TBitmap.Draw делегирует масштабирование WinAPI, и нет проблем.
    Bmp := TBitmap.Create;
    try
      Bmp.Assign(Png);
      Graphic := Bmp;
      Result := True;
    except
      Bmp.Free;
      raise;
    end;
  finally
    Png.Free;
  end;
end;

// Загрузка CF_DIBV5
function TryLoadDIBV5(out Graphic: TGraphic): Boolean;
var
  Stream: TMemoryStream;
  Header: PBitmapV5Header;
  Bits: PByte;
  Width, Height: Integer;
  TopDown: Boolean;
  Bmp: TBitmap;
  Y, SrcY: Integer;
  SrcRow, DstRow: PByte;
  RowSize: Integer;
begin
  Result := False;
  Graphic := nil;

  Stream := GetClipboardStream(CF_DIBV5);
  if Stream = nil then
    exit;

  try
    // Проверяем минимальный размер
    if Stream.Size < SizeOf(TBITMAPV5HEADER) then
      exit;

    Header := PBitmapV5Header(Stream.Memory);

    // Работаем только с 32-битными данными, 
    // только они содержат альфа-канал.
    // Остальное проще отдать стандартному обработчику CF_DIB.
    if Header^.bV5BitCount <> 32 then
      exit;

    Width := Header^.bV5Width;
    Height := Abs(Header^.bV5Height);
    TopDown := Header^.bV5Height < 0;

    if (Width <= 0) or (Height <= 0) then
      exit;

    // Пиксельные данные идут сразу за заголовком
    Bits := PByte(Stream.Memory) + SizeOf(TBITMAPV5HEADER);
    RowSize := Width * 4;

    // Проверяем, что данных достаточно
    if Stream.Size < SizeOf(TBITMAPV5HEADER) + 
      NativeUInt(RowSize) * NativeUInt(Height) then
      exit;

    // Если альфа-канал пуст, то заполняем 255.
    // Такое бывает, когда CF_DIBV5 синтезирован Windows из CF_DIB,
    // в котором альфы не было.
    if not HasAlpha(Bits, Width * Height) then
      FillAlpha(Bits, Width * Height);

    Bmp := TBitmap.Create;
    try
      Bmp.PixelFormat := pf32bit;
      Bmp.AlphaFormat := afDefined;
      Bmp.SetSize(Width, Height);

      // Копируем строки с учётом порядка.
      // DIB по умолчанию хранит строки снизу вверх (bottom-up, bV5Height > 0).
      // TBitmap.ScanLine[0] - всегда верхняя строка.
      for Y := 0 to Height - 1 do
      begin
        if TopDown then
          SrcY := Y
        else
          SrcY := Height - 1 - Y;

        SrcRow := Bits + NativeUInt(SrcY) * NativeUInt(RowSize);
        DstRow := Bmp.ScanLine[Y];
        Move(SrcRow^, DstRow^, RowSize);
      end;

      Graphic := Bmp;
      Result := True;
    except
      Bmp.Free;
      raise;
    end;
  finally
    Stream.Free;
  end;
end;

// Загрузка через стандартный VCL
function TryLoadVCL(out Graphic: TGraphic): Boolean;
var Pic: TPicture;
begin
  Result := False;
  Graphic := nil;

  if not Clipboard.HasFormat(CF_BITMAP) then
    exit;

  Pic := TPicture.Create;
  try
    try
      Pic.Assign(Clipboard);
    except
      exit;
    end;

    if (Pic.Graphic = nil) or Pic.Graphic.Empty then
      exit;

    Graphic := TBitmap.Create;
    Graphic.Assign(Pic.Graphic);
    Result := True;
  finally
    Pic.Free;
  end;
end;

// Каскадная загрузка
function TryLoadGraphicFromClipboard(out Graphic: TGraphic): Boolean;
begin
  // PNG: альфа-канал сохраняется как есть
  if TryLoadPNG(Graphic) then
    exit(True);

  // CF_DIBV5: ручной разбор 32-битных данных с альфой
  if TryLoadDIBV5(Graphic) then
    exit(True);

  // Стандартный VCL: альфа будет потеряна (но это не точно :))
  if TryLoadVCL(Graphic) then
    exit(True);

  Graphic := nil;
  Result := False;
end;

{$EndRegion}

{$Region 'Вспомогательные функции (сохранение в буфер)'}

// Конвертирует произвольный TGraphic в 32-битный TBitmap с альфа-каналом.
// Если входной Graphic уже TBitmap pf32bit - копирует как есть.
// Если TPngImage - использует Assign для сохранения альфы.
// Для остальных - рисует на канве, альфа будет 255 (непрозрачный).
function GraphicTo32Bitmap(Graphic: TGraphic): TBitmap;
begin
  Result := TBitmap.Create;
  try
    if Graphic is TBitmap then
    begin
      Result.Assign(Graphic);
      Result.PixelFormat := pf32bit;
    end
    else if Graphic is TPngImage then
    begin
      // Assign из TPngImage сохраняет альфа-канал
      Result.Assign(Graphic);
    end
    else
    begin
      // Произвольный TGraphic - рисуем на канве, альфа = 255
      Result.PixelFormat := pf32bit;
      Result.SetSize(Graphic.Width, Graphic.Height);
      Result.Canvas.Draw(0, 0, Graphic);
      FillAlpha(Result.ScanLine[Result.Height - 1],
        Result.Width * Result.Height);
    end;

    Result.PixelFormat := pf32bit;
    Result.AlphaFormat := afDefined;
  except
    Result.Free;
    raise;
  end;
end;

// Помещает блок данных в буфер обмена как указанный формат.
// Буфер должен быть уже открыт (Clipboard.Open).
function SetClipboardData(AFormat: Word; Data: Pointer; 
  Size: NativeUInt): Boolean;
var H: THandle; Ptr: Pointer;
begin
  Result := False;

  H := GlobalAlloc(GMEM_MOVEABLE, Size);
  if H = 0 then
    exit;

  Ptr := GlobalLock(H);
  if Ptr = nil then
  begin
    GlobalFree(H);
    exit;
  end;

  try
    Move(Data^, Ptr^, Size);
  finally
    GlobalUnlock(H);
  end;

  // После SetClipboardData система владеет памятью - не освобождаем
  if Winapi.Windows.SetClipboardData(AFormat, H) = 0 then
  begin
    GlobalFree(H);
    exit;
  end;

  Result := True;
end;

{$EndRegion}

{$Region 'Сохранение в буфер обмена'}

// Сохранение PNG
function TrySavePNG(Graphic: TGraphic): Boolean;
var S: TMemoryStream; Png: TPngImage;
begin
  Result := False;

  if CF_PNG = 0 then
    exit;

  Png := TPngImage.Create;
  try
    Png.Assign(Graphic);

    S := TMemoryStream.Create;
    try
      Png.SaveToStream(S);

      Clipboard.Open;
      try
        Result := SetClipboardData(CF_PNG, S.Memory, S.Size);
      finally
        Clipboard.Close;
      end;
    finally
      S.Free;
    end;
  finally
    Png.Free;
  end;
end;

// Сохранение CF_DIBV5
function TrySaveDIBV5(Graphic: TGraphic): Boolean;
var
  Bmp: TBitmap;
  Header: TBITMAPV5HEADER;
  Width, Height: Integer;
  RowSize: Integer;
  DataSize: NativeUInt;
  Buffer: TMemoryStream;
  Y: Integer;
  SrcRow: PByte;
begin
  Result := False;

  Bmp := GraphicTo32Bitmap(Graphic);
  try
    Width := Bmp.Width;
    Height := Bmp.Height;
    RowSize := Width * 4;

    // Формируем заголовок
    FillChar(Header, SizeOf(Header), 0);
    Header.bV5Size := SizeOf(TBITMAPV5HEADER);
    Header.bV5Width := Width;
    Header.bV5Height := -Height; // top-down - строки сверху вниз
    Header.bV5Planes := 1;
    Header.bV5BitCount := 32;
    Header.bV5Compression := BI_BITFIELDS;
    Header.bV5SizeImage := RowSize * Height;
    Header.bV5RedMask   := $00FF0000;
    Header.bV5GreenMask := $0000FF00;
    Header.bV5BlueMask  := $000000FF;
    Header.bV5AlphaMask := $FF000000;
    Header.bV5CSType := $73524742; // 'sRGB'
    Header.bV5Intent := LCS_GM_IMAGES;

    DataSize := SizeOf(Header) + NativeUInt(RowSize) * NativeUInt(Height);

    Buffer := TMemoryStream.Create;
    try
      Buffer.SetSize(DataSize);

      // Пишем заголовок
      Move(Header, Buffer.Memory^, SizeOf(Header));

      // Пишем пиксельные строки (top-down - прямой порядок)
      for Y := 0 to Height - 1 do
      begin
        SrcRow := Bmp.ScanLine[Y];
        Move(SrcRow^, PByte(PByte(Buffer.Memory) +
          SizeOf(Header) + NativeUInt(Y) * NativeUInt(RowSize))^, RowSize);
      end;

      Clipboard.Open;
      try
        Result := SetClipboardData(CF_DIBV5, Buffer.Memory, DataSize);
      finally
        Clipboard.Close;
      end;
    finally
      Buffer.Free;
    end;
  finally
    Bmp.Free;
  end;
end;

// Сохранение через стандартный VCL
function TrySaveVCL(Graphic: TGraphic): Boolean;
begin
  Result := False;
  try
    Clipboard.Assign(Graphic);
    Result := True;
  except
    // Тут молчим, это последний резерв
    // Если и здесь упало, просто возвращаем False
  end;
end;

// Каскадное сохранение
function TrySaveGraphicToClipboard(Graphic: TGraphic): Boolean;
var SavedPNG, SavedDIBV5: Boolean;
begin
  if (Graphic = nil) or Graphic.Empty then
    exit(False);

  // Очищаем буфер один раз перед записью всех форматов
  Clipboard.Open;
  try
    Clipboard.Clear;
  finally
    Clipboard.Close;
  end;

  // Кладём оба формата - каждый для своих потребителей
  SavedPNG := TrySavePNG(Graphic);
  SavedDIBV5 := TrySaveDIBV5(Graphic);

  // Достаточно, если хотя бы один формат лёг успешно.
  // CF_DIB и CF_BITMAP Windows синтезирует из CF_DIBV5 автоматически.
  if SavedPNG or SavedDIBV5 then
    exit(True);

  Result := TrySaveVCL(Graphic);
end;

{$EndRegion}

{$Region 'Инициализация'}

initialization
  CF_PNG := RegisterClipboardFormat('PNG');

{$EndRegion}

end.

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

142

143

144

145

146

147

148

149

150

151

152

153

154

155

156

157

158

159

160

161

162

163

164

165

166

167

168

169

170

171

172

173

174

175

176

177

178

179

180

181

182

183

184

185

186

187

188

189

190

191

192

193

194

195

196

197

198

199

200

201

202

203

204

205

206

207

208

209

210

211

212

213

214

215

216

217

218

219

220

221

222

223

224

225

226

227

228

229

230

231

232

233

234

235

236

237

238

239

240

241

242

243

244

245

246

247

248

249

250

251

252

253

254

255

256

257

258

259

260

261

262

263

264

265

266

267

268

269

270

271

272

273

274

275

276

277

278

279

280

281

282

283

284

285

286

287

288

289

290

291

292

293

294

295

296

297

298

299

300

301

302

303

304

305

306

307

308

309

310

311

312

313

314

315

316

317

318

319

320

321

322

323

324

325

326

327

328

329

330

331

332

333

334

335

336

337

338

339

340

341

342

343

344

345

346

347

348

349

350

351

352

353

354

355

356

357

358

359

360

361

362

363

364

365

366

367

368

369

370

371

372

373

374

375

376

377

378

379

380

381

382

383

384

385

386

387

388

389

390

391

392

393

394

395

396

397

398

399

400

401

402

403

404

405

406

407

408

409

410

411

412

413

414

415

416

417

418

419

420

421

422

423

424

425

426

427

428

429

430

431

432

433

434

435

436

437

438

439

440

441

442

443

444

445

446

447

448

449

450

451

452

453

454

455

456

457

458

459

460

461

462

463

464

465

466

467

468

469

470

471

472

473

474

475

476

477

478

479

480

481

482

483

484

485

486

487

488

489

490

491

492

493

494

495

496

497

498

499

500

501

502

503

504

505

506

507

508

509

510

511

512

513

514

515

516

517

518

519

520

521

522

523

524

525

526

527

528

529

530

531

532

533

534

535

536

537

538

539

540

541

542

543

544

545

546

547

548

549

//******************************************************************************

// Project: IP76.RU

// Created: 2026-02-12

// Article: https://ip76.ru/clipbrd-alpha/

// Описание: Модуль для обмена изображениями через буфер обмена

// без потери альфа-канала

//------------------------------------------------------------------------------

// Загрузка из буфера:

// function TryLoadGraphicFromClipboard(out Graphic: TGraphic): Boolean;

// Стандартный VCL (TPicture/TClipboard) теряет альфа-канал при вставке

// Функция реализует каскадную загрузку: сначала пробуем PNG,

// затем CF_DIBV5 с ручным разбором альфы, и только потом,

// если ничего не сработало, используем стандартный механизм VCL

//------------------------------------------------------------------------------

// Сохранение в буфер:

// function TrySaveGraphicToClipboard(Graphic: TGraphic): Boolean;

// Стандартный VCL кладёт только CF_BITMAP, получатель может не увидеть альфу

// Функция кладёт сразу PNG и CF_DIBV5 с альфа-каналом

// CF_DIB и CF_BITMAP Windows синтезирует автоматически

//******************************************************************************

unit IP76.Imaging.Clipbrd;

interface

uses

Winapi.Windows,

System.SysUtils, System.Classes,

Vcl.Graphics;

// Каскадная загрузка изображения из буфера обмена

// Пробует форматы в порядке приоритета: PNG->CF_DIBV5->стандартный VCL

// Возвращает True, если удалось загрузить

// Graphic создаётся внутри - вызывающий отвечает за освобождение

function TryLoadGraphicFromClipboard(out Graphic: TGraphic): Boolean;

// Загрузка PNG из буфера обмена

// Многие приложения (браузеры, графические редакторы) кладут PNG -

// это лучший вариант, альфа-канал сохраняется как есть

// Результат конвертируется в TBitmap, чтобы избежать проблем

// с масштабированием в TPngImage.Draw

function TryLoadPNG(out Graphic: TGraphic): Boolean;

// Загрузка CF_DIBV5 с ручным разбором альфа-канала

// Формат CF_DIBV5 поддерживает 32-битные пиксели с альфой,

// но VCL его не обрабатывает, разбираем вручную

// Если альфа-канал пуст (все нули), то заполняем 255

function TryLoadDIBV5(out Graphic: TGraphic): Boolean;

// Загрузка через стандартный механизм VCL (TClipboard.Assign)

function TryLoadVCL(out Graphic: TGraphic): Boolean;

// Каскадное копирование изображения в буфер обмена

// Кладёт PNG + CF_DIBV5 для приложений с поддержкой альфы,

// CF_DIB/CF_BITMAP Windows синтезирует автоматически

// Возвращает True, если удалось положить хотя бы один формат

function TrySaveGraphicToClipboard(Graphic: TGraphic): Boolean;

// Кладёт изображение в буфер как PNG

// Для приложений, понимающих PNG (браузеры, Photoshop, GIMP)

function TrySavePNG(Graphic: TGraphic): Boolean;

// Кладёт изображение в буфер как CF_DIBV5 с альфа-каналом

// Для приложений, читающих DIB с альфой, но не читающих PNG

function TrySaveDIBV5(Graphic: TGraphic): Boolean;

// Кладёт изображение в буфер через стандартный механизм VCL

function TrySaveVCL(Graphic: TGraphic): Boolean;

implementation

uses

Vcl.Clipbrd, Vcl.Imaging.PngImage;

var

CF_PNG: Word;

{$Region 'Вспомогательные функции (загрузка из буфера)'}

// Читает сырые данные формата из буфера обмена в поток

// Возвращает nil, если формат отсутствует или данные пусты

function GetClipboardStream(AFormat: Word): TMemoryStream;

var H: THandle; Ptr: Pointer; Size: NativeUInt;

begin

Result := nil;

Clipboard.Open;

try

H := Clipboard.GetAsHandle(AFormat);

if H = 0 then

exit;

Ptr := GlobalLock(H);

if Ptr = nil then

exit;

try

Size := GlobalSize(H);

if Size = 0 then

exit;

Result := TMemoryStream.Create;

Result.WriteBuffer(Ptr^, Size);

Result.Position := 0;

finally

GlobalUnlock(H);

end;

finally

Clipboard.Close;

end;

// Проверяет, есть ли в массиве пикселей хотя бы одно ненулевое значение альфы

// Если все альфа-байты нулевые, значит альфа-канал не заполнен

function HasAlpha(Bits: PByte; PixelCount: Integer): Boolean;

var I: Integer; P: PByte;

begin

Result := False;

P := Bits;

Inc(P, 3); // встаём на первый альфа-байт (тут BGRA => смещение 3)

for I := 0 to PixelCount - 1 do

begin

if P^ <> 0 then

exit(True);

Inc(P, 4);

end;

// Принудительно заполняет альфа-канал значением 255

procedure FillAlpha(Bits: PByte; PixelCount: Integer);

var I: Integer; P: PByte;

begin

P := Bits;

Inc(P, 3);

for I := 0 to PixelCount - 1 do

begin

P^ := 255;

Inc(P, 4);

end;

{$EndRegion}

{$Region 'Загрузка из буфера обмена'}

// Загрузка PNG

function TryLoadPNG(out Graphic: TGraphic): Boolean;

var S: TMemoryStream; Png: TPngImage; Bmp: TBitmap;

begin

Result := False;

Graphic := nil;

if CF_PNG = 0 then

exit;

S := GetClipboardStream(CF_PNG);

if S = nil then

exit;

Png := TPngImage.Create;

try

Png.LoadFromStream(S);

finally

S.Free;

end;

// Конвертируем в TBitmap.

// TPngImage.Draw при масштабировании слегка глючит:

// https://ip76.ru/tpngimage-stretch-bug/

// TBitmap.Draw делегирует масштабирование WinAPI, и нет проблем.

Bmp := TBitmap.Create;

try

Bmp.Assign(Png);

Graphic := Bmp;

Result := True;

except

Bmp.Free;

raise;

end;

finally

Png.Free;

end;

// Загрузка CF_DIBV5

function TryLoadDIBV5(out Graphic: TGraphic): Boolean;

var

Stream: TMemoryStream;

Header: PBitmapV5Header;

Bits: PByte;

Width, Height: Integer;

TopDown: Boolean;

Bmp: TBitmap;

Y, SrcY: Integer;

SrcRow, DstRow: PByte;

RowSize: Integer;

begin

Result := False;

Graphic := nil;

Stream := GetClipboardStream(CF_DIBV5);

if Stream = nil then

exit;

try

// Проверяем минимальный размер

if Stream.Size < SizeOf(TBITMAPV5HEADER) then

exit;

Header := PBitmapV5Header(Stream.Memory);

// Работаем только с 32-битными данными,

// только они содержат альфа-канал.

// Остальное проще отдать стандартному обработчику CF_DIB.

if Header^.bV5BitCount <> 32 then

exit;

Width := Header^.bV5Width;

Height := Abs(Header^.bV5Height);

TopDown := Header^.bV5Height < 0;

if (Width <= 0) or (Height <= 0) then

exit;

// Пиксельные данные идут сразу за заголовком

Bits := PByte(Stream.Memory) + SizeOf(TBITMAPV5HEADER);

RowSize := Width * 4;

// Проверяем, что данных достаточно

if Stream.Size < SizeOf(TBITMAPV5HEADER) +

NativeUInt(RowSize) * NativeUInt(Height) then

exit;

// Если альфа-канал пуст, то заполняем 255.

// Такое бывает, когда CF_DIBV5 синтезирован Windows из CF_DIB,

// в котором альфы не было.

if not HasAlpha(Bits, Width * Height) then

FillAlpha(Bits, Width * Height);

Bmp := TBitmap.Create;

try

Bmp.PixelFormat := pf32bit;

Bmp.AlphaFormat := afDefined;

Bmp.SetSize(Width, Height);

// Копируем строки с учётом порядка.

// DIB по умолчанию хранит строки снизу вверх (bottom-up, bV5Height > 0).

// TBitmap.ScanLine[0] - всегда верхняя строка.

for Y := 0 to Height - 1 do

begin

if TopDown then

SrcY := Y

else

SrcY := Height - 1 - Y;

SrcRow := Bits + NativeUInt(SrcY) * NativeUInt(RowSize);

DstRow := Bmp.ScanLine[Y];

Move(SrcRow^, DstRow^, RowSize);

end;

Graphic := Bmp;

Result := True;

except

Bmp.Free;

raise;

end;

finally

Stream.Free;

end;

// Загрузка через стандартный VCL

function TryLoadVCL(out Graphic: TGraphic): Boolean;

var Pic: TPicture;

begin

Result := False;

Graphic := nil;

if not Clipboard.HasFormat(CF_BITMAP) then

exit;

Pic := TPicture.Create;

try

Pic.Assign(Clipboard);

except

exit;

end;

if (Pic.Graphic = nil) or Pic.Graphic.Empty then

exit;

Graphic := TBitmap.Create;

Graphic.Assign(Pic.Graphic);

Result := True;

finally

Pic.Free;

end;

// Каскадная загрузка

function TryLoadGraphicFromClipboard(out Graphic: TGraphic): Boolean;

begin

// PNG: альфа-канал сохраняется как есть

if TryLoadPNG(Graphic) then

exit(True);

// CF_DIBV5: ручной разбор 32-битных данных с альфой

if TryLoadDIBV5(Graphic) then

exit(True);

// Стандартный VCL: альфа будет потеряна (но это не точно :))

if TryLoadVCL(Graphic) then

exit(True);

Graphic := nil;

Result := False;

end;

{$EndRegion}

{$Region 'Вспомогательные функции (сохранение в буфер)'}

// Конвертирует произвольный TGraphic в 32-битный TBitmap с альфа-каналом.

// Если входной Graphic уже TBitmap pf32bit - копирует как есть.

// Если TPngImage - использует Assign для сохранения альфы.

// Для остальных - рисует на канве, альфа будет 255 (непрозрачный).

function GraphicTo32Bitmap(Graphic: TGraphic): TBitmap;

begin

Result := TBitmap.Create;

try

if Graphic is TBitmap then

begin

Result.Assign(Graphic);

Result.PixelFormat := pf32bit;

end

else if Graphic is TPngImage then

begin

// Assign из TPngImage сохраняет альфа-канал

Result.Assign(Graphic);

end

else

begin

// Произвольный TGraphic - рисуем на канве, альфа = 255

Result.PixelFormat := pf32bit;

Result.SetSize(Graphic.Width, Graphic.Height);

Result.Canvas.Draw(0, 0, Graphic);

FillAlpha(Result.ScanLine[Result.Height - 1],

Result.Width * Result.Height);

end;

Result.PixelFormat := pf32bit;

Result.AlphaFormat := afDefined;

except

Result.Free;

raise;

end;

// Помещает блок данных в буфер обмена как указанный формат.

// Буфер должен быть уже открыт (Clipboard.Open).

function SetClipboardData(AFormat: Word; Data: Pointer;

Size: NativeUInt): Boolean;

var H: THandle; Ptr: Pointer;

begin

Result := False;

H := GlobalAlloc(GMEM_MOVEABLE, Size);

if H = 0 then

exit;

Ptr := GlobalLock(H);

if Ptr = nil then

begin

GlobalFree(H);

exit;

end;

try

Move(Data^, Ptr^, Size);

finally

GlobalUnlock(H);

end;

// После SetClipboardData система владеет памятью - не освобождаем

if Winapi.Windows.SetClipboardData(AFormat, H) = 0 then

begin

GlobalFree(H);

exit;

end;

Result := True;

end;

{$EndRegion}

{$Region 'Сохранение в буфер обмена'}

// Сохранение PNG

function TrySavePNG(Graphic: TGraphic): Boolean;

var S: TMemoryStream; Png: TPngImage;

begin

Result := False;

if CF_PNG = 0 then

exit;

Png := TPngImage.Create;

try

Png.Assign(Graphic);

S := TMemoryStream.Create;

try

Png.SaveToStream(S);

Clipboard.Open;

try

Result := SetClipboardData(CF_PNG, S.Memory, S.Size);

finally

Clipboard.Close;

end;

finally

S.Free;

end;

finally

Png.Free;

end;

// Сохранение CF_DIBV5

function TrySaveDIBV5(Graphic: TGraphic): Boolean;

var

Bmp: TBitmap;

Header: TBITMAPV5HEADER;

Width, Height: Integer;

RowSize: Integer;

DataSize: NativeUInt;

Buffer: TMemoryStream;

Y: Integer;

SrcRow: PByte;

begin

Result := False;

Bmp := GraphicTo32Bitmap(Graphic);

try

Width := Bmp.Width;

Height := Bmp.Height;

RowSize := Width * 4;

// Формируем заголовок

FillChar(Header, SizeOf(Header), 0);

Header.bV5Size := SizeOf(TBITMAPV5HEADER);

Header.bV5Width := Width;

Header.bV5Height := -Height; // top-down - строки сверху вниз

Header.bV5Planes := 1;

Header.bV5BitCount := 32;

Header.bV5Compression := BI_BITFIELDS;

Header.bV5SizeImage := RowSize * Height;

Header.bV5RedMask := $00FF0000;

Header.bV5GreenMask := $0000FF00;

Header.bV5BlueMask := $000000FF;

Header.bV5AlphaMask := $FF000000;

Header.bV5CSType := $73524742; // 'sRGB'

Header.bV5Intent := LCS_GM_IMAGES;

DataSize := SizeOf(Header) + NativeUInt(RowSize) * NativeUInt(Height);

Buffer := TMemoryStream.Create;

try

Buffer.SetSize(DataSize);

// Пишем заголовок

Move(Header, Buffer.Memory^, SizeOf(Header));

// Пишем пиксельные строки (top-down - прямой порядок)

for Y := 0 to Height - 1 do

begin

SrcRow := Bmp.ScanLine[Y];

Move(SrcRow^, PByte(PByte(Buffer.Memory) +

SizeOf(Header) + NativeUInt(Y) * NativeUInt(RowSize))^, RowSize);

end;

Clipboard.Open;

try

Result := SetClipboardData(CF_DIBV5, Buffer.Memory, DataSize);

finally

Clipboard.Close;

end;

finally

Buffer.Free;

end;

finally

Bmp.Free;

end;

// Сохранение через стандартный VCL

function TrySaveVCL(Graphic: TGraphic): Boolean;

begin

Result := False;

try

Clipboard.Assign(Graphic);

Result := True;

except

// Тут молчим, это последний резерв

// Если и здесь упало, просто возвращаем False

end;

// Каскадное сохранение

function TrySaveGraphicToClipboard(Graphic: TGraphic): Boolean;

var SavedPNG, SavedDIBV5: Boolean;

begin

if (Graphic = nil) or Graphic.Empty then

exit(False);

// Очищаем буфер один раз перед записью всех форматов

Clipboard.Open;

try

Clipboard.Clear;

finally

Clipboard.Close;

end;

// Кладём оба формата - каждый для своих потребителей

SavedPNG := TrySavePNG(Graphic);

SavedDIBV5 := TrySaveDIBV5(Graphic);

// Достаточно, если хотя бы один формат лёг успешно.

// CF_DIB и CF_BITMAP Windows синтезирует из CF_DIBV5 автоматически.

if SavedPNG or SavedDIBV5 then

exit(True);

Result := TrySaveVCL(Graphic);

end;

{$EndRegion}

{$Region 'Инициализация'}

initialization

CF_PNG := RegisterClipboardFormat('PNG');

{$EndRegion}

end.

[свернуть]

Заключение

Стандартный VCL теряет альфа-канал при работе с буфером обмена — и при вставке, и при копировании. Причина не в баге, а в том, что VCL знает только CF_BITMAP, а этот формат не несёт альфу.

Решение — работать с буфером через PNG и CF_DIBV5 напрямую. Модуль IP76.Imaging.Clipbrd делает это за вас: две функции, TryLoadGraphicFromClipboard и TrySaveGraphicToClipboard, закрывают оба направления.

Скачать

Друзья, спасибо за внимание!

Исходник (zip) 68.6 Кб. Delphi XE 7, 13.0 Florence

Исполняемый файл (zip) 1.04 Мб.

5 1 голос

Рейтинг статьи

0 комментариев

Старые

Новые Популярные

Межтекстовые Отзывы

Посмотреть все комментарии