PNG из Bitmap с переносом альфа-канала. И наоборот

Стандартными средствами Delphi можно создать PNG из Bitmap, но альфа-канал при этом теряется. В этой статье разберём, как корректно конвертировать TBitmap в TPngImage с сохранением прозрачности и почему важно учитывать AlphaFormat.

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

PNG из Bitmap

Первая версия функции

Эволюция функции

Что изменилось и почему

Принудительная установка afIgnored

Линейный обход памяти вместо ручной арифметики

Перенос альфа-канала из PNG в Bitmap

Получить Bitmap из TGraphic

Способ 1: Рисуем

Способ 2: Альфа-канал

Пример использования

Скачать

PNG из Bitmap

В 2022 году я написал функцию, которая решала эту задачу — копировала альфа-байты из 32-битного битмапа в TPngImage. Функция работала, но содержала проблемы: ручную арифметику указателей, несовместимую с Win64, и полное игнорирование AlphaFormat, из-за чего при определённых условиях вокруг полупрозрачных областей появлялась характерная серая окантовка. Разберём, в чём причина, и напишем исправленную версию.

Первая версия функции

// Конвертировать TBitmap в TPngImage с переносом альфа-канала
// Старая версия 2022 года
function BitmapToPNG(const ABitmap: TBitmap;
  const APNG: TPngImage): TPngImage; overload;
var
  dStep: Integer;
  p,d,v: PByte;
  x,y: Integer;
begin
  if Assigned(APNG) then
    Result := APNG
  else if Assigned(ABitmap) then
    Result := TPngImage.Create
  else
    Result := nil;

  if Assigned(ABitmap) then
  begin
    try
      Result.Assign(ABitmap);
      // если не вызывать CreateAlpha, AlphaScanline будет равен nil
      // также, CreateAlpha установит 
      // ColorType=COLOR_RGBALPHA(COLOR_GRAYSCALEALPHA)
      Result.CreateAlpha;
      // если этого не сделать, фон будет черным и непрозрачным
      if ABitmap.PixelFormat = pf32Bit then
      begin
        dStep := BytesPerScanline(ABitmap.Width, 32, 32);
        d := ABitmap.Scanline[0];

        for y := 0 to ABitmap.height-1 do
        begin
          p := PByte(Integer(d) - y*dStep);
          v := @Result.AlphaScanline[y]^[0];
          for x := 0 to ABitmap.Width-1 do
          begin
            v^ := PRGBQuad(p)^.rgbReserved;
            inc(p, SizeOf(TRGBQuad));
            inc(v);
          end;
        end;
      end;

    except
      FreeAndNil(Result);
    end;
  end;
end;

// Конвертировать TBitmap в TPngImage с переносом альфа-канала

// Старая версия 2022 года

function BitmapToPNG(const ABitmap: TBitmap;

const APNG: TPngImage): TPngImage; overload;

var

dStep: Integer;

p,d,v: PByte;

x,y: Integer;

begin

if Assigned(APNG) then

Result := APNG

else if Assigned(ABitmap) then

Result := TPngImage.Create

else

Result := nil;

if Assigned(ABitmap) then

begin

try

Result.Assign(ABitmap);

// если не вызывать CreateAlpha, AlphaScanline будет равен nil

// также, CreateAlpha установит

// ColorType=COLOR_RGBALPHA(COLOR_GRAYSCALEALPHA)

Result.CreateAlpha;

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

if ABitmap.PixelFormat = pf32Bit then

begin

dStep := BytesPerScanline(ABitmap.Width, 32, 32);

d := ABitmap.Scanline[0];

for y := 0 to ABitmap.height-1 do

begin

p := PByte(Integer(d) - y*dStep);

v := @Result.AlphaScanline[y]^[0];

for x := 0 to ABitmap.Width-1 do

begin

v^ := PRGBQuad(p)^.rgbReserved;

inc(p, SizeOf(TRGBQuad));

inc(v);

end;

except

FreeAndNil(Result);

end;

Функция рабочая, но в ряде случаев могла выдать PNG с серой каймой вокруг изображения:

Эволюция функции

Пока разбирался с глюком PNG, выяснил, как TPngImage формирует прозрачность при отрисовке. Это объяснило причину серой окантовки и потребовало переработки функции.

// Конвертировать TBitmap в TPNGImage с переносом альфа-канала
// Новая версия 2026 года
function BitmapToPNG(ABitmap: TBitmap): TPNGImage; overload;
var
  V: PByte;
  P: PRGBQuad;
  X, Y, W, H: Integer;
  SavedAF: TAlphaFormat;
begin
  if ABitmap = nil then
    Exit(nil);

  W := ABitmap.Width;
  H := ABitmap.Height;

  if (W = 0) or (H = 0) then
    Exit(nil);

  Result := TPNGImage.Create;
  try
    if ABitmap.PixelFormat = pf32bit then
    begin
      SavedAF := ABitmap.AlphaFormat;
      ABitmap.AlphaFormat := afIgnored;
      try
        Result.Assign(ABitmap);
        Result.CreateAlpha;
        if Result.AlphaScanline[0] = nil then
          exit;

        P := ABitmap.ScanLine[H - 1];
        for Y := H - 1 downto 0 do
        begin
          V := @Result.AlphaScanline[Y]^[0];
          for X := 0 to W - 1 do
          begin
            V^ := P^.rgbReserved;
            Inc(P);
            Inc(V);
          end;
        end;
      finally
        ABitmap.AlphaFormat := SavedAF;
      end;
    end
    else
      Result.Assign(ABitmap);
  except
    FreeAndNil(Result);
    raise;
  end;
end;

// Конвертировать TBitmap в TPNGImage с переносом альфа-канала

// Новая версия 2026 года

function BitmapToPNG(ABitmap: TBitmap): TPNGImage; overload;

var

V: PByte;

P: PRGBQuad;

X, Y, W, H: Integer;

SavedAF: TAlphaFormat;

begin

if ABitmap = nil then

Exit(nil);

W := ABitmap.Width;

H := ABitmap.Height;

if (W = 0) or (H = 0) then

Exit(nil);

Result := TPNGImage.Create;

try

if ABitmap.PixelFormat = pf32bit then

begin

SavedAF := ABitmap.AlphaFormat;

ABitmap.AlphaFormat := afIgnored;

try

Result.Assign(ABitmap);

Result.CreateAlpha;

if Result.AlphaScanline[0] = nil then

exit;

P := ABitmap.ScanLine[H - 1];

for Y := H - 1 downto 0 do

begin

V := @Result.AlphaScanline[Y]^[0];

for X := 0 to W - 1 do

begin

V^ := P^.rgbReserved;

Inc(P);

Inc(V);

end;

finally

ABitmap.AlphaFormat := SavedAF;

end;

end

else

Result.Assign(ABitmap);

except

FreeAndNil(Result);

raise;

end;

Что изменилось и почему

Принудительная установка afIgnored

Это ключевое исправление. Свойство TBitmap.AlphaFormat определяет, как GDI и VCL интерпретируют содержимое альфа-канала:

Значение	Смысл
afIgnored	Альфа-байт хранится как есть, цвета — straight (не домножены)
afDefined	Альфа учитывается при отрисовке; GDI хранит цвета в формате premultiplied alpha
afPremultiplied	То же, что afDefined, данные уже premultiplied

Формат premultiplied alpha означает, что каждый цветовой компонент пикселя домножен на значение альфы:

R_stored = R_real × A / 255
G_stored = G_real × A / 255
B_stored = B_real × A / 255

R_stored = R_real × A / 255

G_stored = G_real × A / 255

B_stored = B_real × A / 255

TPngImage, напротив, работает исключительно со straight alpha: цветовые компоненты хранятся в исходном виде, а альфа-канал задаётся отдельно. При отрисовке TPngImage сам формирует прозрачность, комбинируя цвет и альфу.

Если скопировать premultiplied-данные в TPngImage без обратного преобразования, произойдёт двойное применение альфы: сначала цвета уже приглушены домножением, а затем TPngImage при отрисовке применит альфу ещё раз. Визуально это проявляется как серая или тёмная окантовка вокруг полупрозрачных краёв и общее затемнение полупрозрачных областей.

Установка ABitmap.AlphaFormat := afIgnored перед вызовом Result.Assign(ABitmap) гарантирует, что VCL передаст цветовые данные в straight-формате. После копирования исходное значение AlphaFormat восстанавливается в блоке finally, чтобы не нарушить дальнейшую работу с битмапом.

Важно: переключение AlphaFormat туда и обратно может исказить пиксельные данные битмапа (VCL выполняет внутренние преобразования при смене этого свойства). Если битмап после вызова BitmapToPNG больше не нужен, его необходимо освободить. Если нужен, то безопаснее передавать в функцию копию.

Линейный обход памяти вместо ручной арифметики

В 32-битном DIB каждый пиксель занимает ровно 4 байта (SizeOf(TRGBQuad)). Строка из W пикселей занимает W × 4 байт. Выравнивание строк в Windows DIB происходит по границе 4 байт (DWORD), а W × 4 всегда кратно четырём при любом значении W. Это означает, что между строками нет «дырок» (padding-байтов) и все пиксели расположены в памяти непрерывно.

Подробно об этом рассказано в статье TBitmap.ScanLine.

Стандартный формат хранения DIB — bottom-up: строка с индексом 0 (верхняя в изображении) находится в памяти последней, а строка Height-1 (нижняя) — первой, по наименьшему адресу. Вызов ScanLine[Height-1] возвращает указатель на самое начало пиксельного буфера.

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

// начало буфера (нижняя строка битмапа)
P := ABitmap.ScanLine[H - 1];
// от нижней строки к верхней
for Y := H - 1 downto 0 do      
begin
  V := @Result.AlphaScanline[Y]^[0];
  for X := 0 to W - 1 do
  begin
    V^ := P^.rgbReserved;
    Inc(P); // следующий TRGBQuad, всегда +4 байта
    Inc(V);
  end;
end;

// начало буфера (нижняя строка битмапа)

P := ABitmap.ScanLine[H - 1];

// от нижней строки к верхней

for Y := H - 1 downto 0 do

begin

V := @Result.AlphaScanline[Y]^[0];

for X := 0 to W - 1 do

begin

V^ := P^.rgbReserved;

Inc(P); // следующий TRGBQuad, всегда +4 байта

Inc(V);

end;

Указатель P имеет тип PRGBQuad, поэтому Inc(P) сдвигает его ровно на SizeOf(TRGBQuad) = 4 байта, к следующему пикселю. Никакой дополнительной арифметики не требуется.

Сравните со старой версией, где адрес каждой строки вычислялся вручную:

dStep := BytesPerScanline(ABitmap.Width, 32, 32);
d := ABitmap.Scanline[0];
p := PByte(Integer(d) - y * dStep); // опасно в Win64!

dStep := BytesPerScanline(ABitmap.Width, 32, 32);

d := ABitmap.Scanline[0];

p := PByte(Integer(d) - y * dStep); // опасно в Win64!

Приведение указателя к Integer обрезает старшие 4 байта адреса в 64-битном процессе, что приводит к access violation или повреждению памяти. Новая версия не содержит подобной арифметики и корректно работает как в 32-битных, так и в 64-битных приложениях.

Перенос альфа-канала из PNG в Bitmap

Обратная задача — взять альфа-канал из TPngImage и записать его в 32-битный TBitmap. Это полезно, когда нужно наложить прозрачность одного изображения на содержимое другого. Функция принимает PNG-источник альфы и битмап-приёмник; размеры могут не совпадать — копируется область пересечения.

// Перенести альфа-канал из PNG в растровое изображение
function SetPngAlphaToBitmap(const AImage: TPngImage;
  const ABitmap: TBitmap): TBitmap;
var
  X, Y, W, H: Integer;
  Dst: PRGBQuad;
  Src: PByte;
begin
  Result := ABitmap;

  if not Assigned(Result) or not Assigned(AImage) then
    Exit;
  if (Result.PixelFormat <> pf32bit) or (Result.Height < 1) then
    Exit;

  AImage.CreateAlpha;
  if AImage.AlphaScanline[0] = nil then
    Exit;

  W := Min(AImage.Width, ABitmap.Width);
  H := Min(AImage.Height, ABitmap.Height);

  for Y := 0 to H - 1 do
  begin
    Src := @AImage.AlphaScanline[Y]^[0];
    Dst := ABitmap.ScanLine[Y];
    for X := 0 to W - 1 do
    begin
      Dst^.rgbReserved := Src^;
      Inc(Dst);
      Inc(Src);
    end;
  end;
end;

// Перенести альфа-канал из PNG в растровое изображение

function SetPngAlphaToBitmap(const AImage: TPngImage;

const ABitmap: TBitmap): TBitmap;

var

X, Y, W, H: Integer;

Dst: PRGBQuad;

Src: PByte;

begin

Result := ABitmap;

if not Assigned(Result) or not Assigned(AImage) then

Exit;

if (Result.PixelFormat <> pf32bit) or (Result.Height < 1) then

Exit;

AImage.CreateAlpha;

if AImage.AlphaScanline[0] = nil then

Exit;

W := Min(AImage.Width, ABitmap.Width);

H := Min(AImage.Height, ABitmap.Height);

for Y := 0 to H - 1 do

begin

Src := @AImage.AlphaScanline[Y]^[0];

Dst := ABitmap.ScanLine[Y];

for X := 0 to W - 1 do

begin

Dst^.rgbReserved := Src^;

Inc(Dst);

Inc(Src);

end;

В отличие от BitmapToPNG, здесь мы не используем линейный обход одним указателем, а запрашиваем ScanLine[Y] на каждой строке. Причина в том, что размеры PNG и битмапа — независимые параметры. Если ширина PNG меньше ширины битмапа, внутренний цикл обработает только W = Min(AImage.Width, ABitmap.Width) пикселей, но указатель, бегущий линейно по памяти битмапа, не узнает, что строка на самом деле длиннее. На следующей итерации он продолжит с того места, где остановился — со смещением внутрь той же строки, а не с начала следующей. Альфа-канал «поедет» вправо с каждой строкой.

В BitmapToPNG этой проблемы нет: PNG создаётся из того же битмапа, размеры всегда совпадают, и линейный обход корректен. Здесь же ScanLine[Y] гарантирует правильный адрес начала строки независимо от соотношения размеров.

Переносить альфа-канал можно на что угодно. Например, у нас есть PNG с чуть размытым по Гауссу содержимым.

И некий абстрактный фон. Допустим, такой jpg.

Теперь, если преобразовать JPG с рисунка 2 в битмап и перенести в этот битмап альфа-канал из рисунка 1, то получится следующее:

Получить Bitmap из TGraphic

Битмап в графике нужен всегда. Для обработки и анализа изображения. Для переноса данных из одного формата в другой. Просто для отрисовки. Все графические форматы рисуют не себя, а битмап, который формируется на основании данных, хранящихся в нем.

Способ 1: Рисуем

Не всегда графический формат согласен отдать свой внутренний битмап. Использование Assign также может не дать желаемого результата. Поэтому будем просто рисовать на битмапе искомый TGraphic.

// Создать TBitmap из TGraphic
// Если AMaxWidth > 0, будет вычислен пропорциональный размер и
// отмасштабирован с помощью GDI (т.е. без особых бикубичностей)
function LoadBitmapFromGraphic(const AGraphic: TGraphic;
  const AMaxWidth: Integer = -1): TBitmap;  overload;
var Stretch: boolean;
begin
  if (not Assigned(AGraphic)) or (AGraphic.Width<=0) then
    Exit(nil);

  Result := TBitmap.Create;
  if AGraphic is TPngImage then
    Result.PixelFormat := pf32Bit;
  Stretch := False;

  if AMaxWidth < 1 then
    Result.SetSize(AGraphic.Width, AGraphic.Height)
  else
  begin
    Stretch := True;
    Result.SetSize(AMaxWidth,
      round ((AMaxWidth * AGraphic.Height) / AGraphic.Width));
  end;

  if Stretch then
    Result.Canvas.StretchDraw (GetImageRect(Result), AGraphic)
  else begin
    Result.Canvas.Draw (0, 0, AGraphic);
    if AGraphic is TPngImage then
    begin
    // Result := SetPngAlphaToBitmap(AGraphic as TPngImage, Result);
    end;
  end;
end;

// Создать TBitmap из TGraphic

// Если AMaxWidth > 0, будет вычислен пропорциональный размер и

// отмасштабирован с помощью GDI (т.е. без особых бикубичностей)

function LoadBitmapFromGraphic(const AGraphic: TGraphic;

const AMaxWidth: Integer = -1): TBitmap; overload;

var Stretch: boolean;

begin

if (not Assigned(AGraphic)) or (AGraphic.Width<=0) then

Exit(nil);

Result := TBitmap.Create;

if AGraphic is TPngImage then

Result.PixelFormat := pf32Bit;

Stretch := False;

if AMaxWidth < 1 then

Result.SetSize(AGraphic.Width, AGraphic.Height)

else

begin

Stretch := True;

Result.SetSize(AMaxWidth,

round ((AMaxWidth * AGraphic.Height) / AGraphic.Width));

end;

if Stretch then

Result.Canvas.StretchDraw (GetImageRect(Result), AGraphic)

else begin

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

if AGraphic is TPngImage then

begin

// Result := SetPngAlphaToBitmap(AGraphic as TPngImage, Result);

end;

Почему закомментирован вызов SetPngAlphaToBitmap. Потому что не всегда нужно переносить альфа-канал. Если это необходимо, вполне можно вызвать после LoadBitmapFromGraphic.

Для работы с альфа-каналом у нас есть отдельная функция.

Способ 2: Альфа-канал

Метод Assign для потомков TGraphic вещь универсальная. В силу этого не всегда делает то, что хочется. Поэтому чуть модифицируем и дополним.

// Если есть хотя бы один альфа-байт <> 0, результат TRUE
function CheckBitmapAlpha(const ABitmap: TBitmap): Boolean;
var i, Total: Integer; P: PRGBQuad;
begin
  Result := False;
  if (ABitmap=nil) or (ABitmap.PixelFormat <> pf32bit) or
    (ABitmap.Height<1) then
    Exit;

  Total := ABitmap.Width * ABitmap.Height;
  P := ABitmap.ScanLine[ABitmap.Height-1];
  for i := 0 to Total-1 do
  begin
    if P^.rgbReserved <> 0 then
      Exit(True);
    Inc(P)
  end;
end;

// Установить все альфа-байты в указанное значение
function SetBitmapAlpha(const ABitmap: TBitmap;
  const Alpha: Byte=255): TBitmap;
var i, Total: Integer; P: PRGBQuad;
begin
  Result := ABitmap;
  if (Result=nil) or (Result.PixelFormat <> pf32bit) or
    (Result.Height<1) then
    Exit;

  P := ABitmap.ScanLine[ABitmap.Height-1];
  Total := ABitmap.Width * ABitmap.Height;

  for i := 0 to Total-1 do
  begin
    P^.rgbReserved := Alpha;
    inc(P)
  end;
end;

// Создать bitmap из TGraphic методом Assign
function LoadBitmapFromGraphic(const AGraphic: TGraphic;
  const APixelFormat: TPixelFormat = pf32Bit): TBitmap; overload;
begin
  Result := nil;
  if (not Assigned(AGraphic) or AGraphic.Empty) then
    Exit;
  Result := TBitmap.Create;
  try
    Result.Assign(AGraphic);
    if APixelFormat in [pf8bit..pf32bit] then
      Result.PixelFormat := APixelFormat;
    // если все альфа-байты равны 0, то картинка непрозрачная
    // тогда все альфа-байты должны быть установлены в 255
    if Result.PixelFormat = pf32bit then
    begin
      if not CheckBitmapAlpha(Result) then
        SetBitmapAlpha(Result)
   // else
   //   Result.AlphaFormat := afDefined;
    end;
  except
    FreeAndNil(Result);
    raise;
  end;
end;

// Если есть хотя бы один альфа-байт <> 0, результат TRUE

function CheckBitmapAlpha(const ABitmap: TBitmap): Boolean;

var i, Total: Integer; P: PRGBQuad;

begin

Result := False;

if (ABitmap=nil) or (ABitmap.PixelFormat <> pf32bit) or

(ABitmap.Height<1) then

Exit;

Total := ABitmap.Width * ABitmap.Height;

P := ABitmap.ScanLine[ABitmap.Height-1];

for i := 0 to Total-1 do

begin

if P^.rgbReserved <> 0 then

Exit(True);

Inc(P)

end;

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

function SetBitmapAlpha(const ABitmap: TBitmap;

const Alpha: Byte=255): TBitmap;

var i, Total: Integer; P: PRGBQuad;

begin

Result := ABitmap;

if (Result=nil) or (Result.PixelFormat <> pf32bit) or

(Result.Height<1) then

Exit;

P := ABitmap.ScanLine[ABitmap.Height-1];

Total := ABitmap.Width * ABitmap.Height;

for i := 0 to Total-1 do

begin

P^.rgbReserved := Alpha;

inc(P)

end;

// Создать bitmap из TGraphic методом Assign

function LoadBitmapFromGraphic(const AGraphic: TGraphic;

const APixelFormat: TPixelFormat = pf32Bit): TBitmap; overload;

begin

Result := nil;

if (not Assigned(AGraphic) or AGraphic.Empty) then

Exit;

Result := TBitmap.Create;

try

Result.Assign(AGraphic);

if APixelFormat in [pf8bit..pf32bit] then

Result.PixelFormat := APixelFormat;

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

// тогда все альфа-байты должны быть установлены в 255

if Result.PixelFormat = pf32bit then

begin

if not CheckBitmapAlpha(Result) then

SetBitmapAlpha(Result)

// else

// Result.AlphaFormat := afDefined;

end;

except

FreeAndNil(Result);

raise;

end;

Почему закомментирована последняя строка. Свойство AlphaFormat следует устанавливать после всех операций с альфа-байтами. После вызова функции LoadBitmapFromGraphic, возможно, захочется еще что-то поделать с битмапом. Если свойство AlphaFormat уже будет выставлено, результаты будут крайне забавными.

Что тут происходит. Дело в том, что достаточно часто возникает ситуация, когда мы применили Assign, сделали PixelFormat = pf32bit и выставили AlphaFormat = afDefined, и в результате при отрисовке видим… пустоту! Чистый лист. Нетронутый холст. Такое ощущение, что произошла ошибка.

Но ошибки нет. Просто у нас везде альфа-канал равен 0. Непрозрачная исходная картинка, альфа-канала в ней нет. Мы перенесли данные и, заказав 32 бита, получили в 4-м байте пикселя 0. То есть прозрачный пиксель. И рисует все правильно — просто битмап абсолютно прозрачный.

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

Пример использования

У нас есть два TImage. Image1 отвечает за прозрачный PNG, Image2 — за фон. Открываем графические файлы и вставляем из буфера как было описано ранее.

procedure TFmMain.SetGraphic(const ANum: Integer; const AGraphic: TGraphic);
var

  p: Integer;
  bmp: TBitmap;
begin

  //...
  if ANum = 0 then
  begin
    if AGraphic <> Image1.Picture.Graphic then
      Image1.Picture.Assign(AGraphic);
    lblSize.Caption := IntToStr(AGraphic.Width) + ' x ' +
      IntToStr(AGraphic.Height);
    FreeAndNil(FPNG);
    if AGraphic is TPngImage then
    begin
      FPNG := TPngImage.Create;
      FPNG.Assign(AGraphic)
    end
    else
    begin
      bmp := LoadBitmapFromGraphic(AGraphic, pf32bit);
      try
        FPNG := BitmapToPNG(bmp);
      finally
        FreeAndNil(bmp);
      end;
    end;
    if FPNG <> nil then
      FPNG.CreateAlpha;
  end;

  //...
  pbPaint(pb);
end;

procedure TFmMain.SetGraphic(const ANum: Integer; const AGraphic: TGraphic);

var

p: Integer;

bmp: TBitmap;

begin

//...

if ANum = 0 then

begin

if AGraphic <> Image1.Picture.Graphic then

Image1.Picture.Assign(AGraphic);

lblSize.Caption := IntToStr(AGraphic.Width) + ' x ' +

IntToStr(AGraphic.Height);

FreeAndNil(FPNG);

if AGraphic is TPngImage then

begin

FPNG := TPngImage.Create;

FPNG.Assign(AGraphic)

end

else

begin

bmp := LoadBitmapFromGraphic(AGraphic, pf32bit);

try

FPNG := BitmapToPNG(bmp);

finally

FreeAndNil(bmp);

end;

if FPNG <> nil then

FPNG.CreateAlpha;

end;

//...

pbPaint(pb);

end;

Полный текст лучше посмотреть в исходниках по ссылке ниже. Что тут происходит. Если в Image1 находится TPngImage, то используем Assign. Если что-то другое, а при вставке из буфера нам прилетает TBitmap, используем LoadBitmapFromGraphic из способа 2.

Обработчик события OnPaint компонента pb: TPaintBox выглядит следующим образом:

procedure TFmMain.pbPaint(Sender: TObject);
var
  bmp: TBitmap;
  rct: Trect;
  pbx: TPaintBox;
  src, tmp: TBitmap;
  png: TPngImage;
  start, stop, freq: Int64;
begin
  if not (Assigned(FPNG))then
    Exit;

  if Sender is TPaintBox then
    pbx := Sender as TPaintBox
  else
    pbx := pb;

  rct := pbx.ClientRect;
  bmp := CreateBmpRect(rct, pf32bit);

  // Получить битмап пропорционально ранее созданному PNG
  src := LoadBitmapFromGraphic(Image2.Picture.Graphic, FPNG.Width);
  QueryPerformanceFrequency(freq);
  QueryPerformanceCounter(start);
  try
    if src = nil then
      Exit;
    // Если не 32 бита, две следующие функции с таким
    // битмапом работать не будут
    src.PixelFormat := pf32Bit;
    // Сделать картинку полностью прозрачной
    src := SetBitmapAlpha(src, 0);
    // Перенос альфа-канала
    src := SetPngAlphaToBitmap(FPNG, src);
    // В конце, установка альфа формата
    src.AlphaFormat := afDefined;
    // Посчитать время
    QueryPerformanceCounter(stop);
    Label1.Caption :=
      FormatFloat('###,##0.###',1000*(stop - start)/freq)+' msec';

    with bmp.Canvas do
    begin
      Brush.Color := clWhite;
      FillRect(ClipRect);

      // Блок сравнения с результатом старой функции BitmapToPNG
      if chbCompare.Checked and
        (Image1.Picture.Graphic is TPngImage) then
      begin
       rct := GetProportRect(GetImageRect(Image1.Picture.Graphic),
         rct.Width, rct.Height);
       rct := CenteredRect(pbx.ClientRect, rct);

        if rbtnPng.Checked then
          // Если указано, просто рисуем PNG-исходник
          StretchDraw(rct, Image1.Picture.Graphic)
        else
        begin
          tmp := TBitmap.Create;
          try
            tmp.Assign(Image1.Picture.Graphic);
            if rbtnNew.Checked then
              // Формируем PNG по-новому
              png := BitmapToPNG(tmp)
            else
              // Формируем PNG по-старому
              png := BitmapToPNG(tmp, nil);
            try
              StretchDraw(rct, png)
            finally
              png.Free;
            end;
          finally
            tmp.Free;
          end;
        end;
      end
      else
      begin
        // Получить пропорциональный размерам окна прямоугольник
        rct := GetProportRect(GetImageRect(src),
          rct.Width, rct.Height);
        // Отцентрировать его
        rct := CenteredRect(pbx.ClientRect, rct);
        // Если сравнивать не требуется, просто рисуем
        StretchDraw(rct, src);
      end;

      Brush.Style := bsClear;
      Pen.Color := clBtnShadow;
      Rectangle(ClipRect);
    end;
    pbx.Canvas.Draw(0, 0, bmp);
  finally
    FreeAndNil(bmp);
    FreeAndNil(src);
  end;
end;

procedure TFmMain.pbPaint(Sender: TObject);

var

bmp: TBitmap;

rct: Trect;

pbx: TPaintBox;

src, tmp: TBitmap;

png: TPngImage;

start, stop, freq: Int64;

begin

if not (Assigned(FPNG))then

Exit;

if Sender is TPaintBox then

pbx := Sender as TPaintBox

else

pbx := pb;

rct := pbx.ClientRect;

bmp := CreateBmpRect(rct, pf32bit);

// Получить битмап пропорционально ранее созданному PNG

src := LoadBitmapFromGraphic(Image2.Picture.Graphic, FPNG.Width);

QueryPerformanceFrequency(freq);

QueryPerformanceCounter(start);

try

if src = nil then

Exit;

// Если не 32 бита, две следующие функции с таким

// битмапом работать не будут

src.PixelFormat := pf32Bit;

// Сделать картинку полностью прозрачной

src := SetBitmapAlpha(src, 0);

// Перенос альфа-канала

src := SetPngAlphaToBitmap(FPNG, src);

// В конце, установка альфа формата

src.AlphaFormat := afDefined;

// Посчитать время

QueryPerformanceCounter(stop);

Label1.Caption :=

FormatFloat('###,##0.###',1000*(stop - start)/freq)+' msec';

with bmp.Canvas do

begin

Brush.Color := clWhite;

FillRect(ClipRect);

// Блок сравнения с результатом старой функции BitmapToPNG

if chbCompare.Checked and

(Image1.Picture.Graphic is TPngImage) then

begin

rct := GetProportRect(GetImageRect(Image1.Picture.Graphic),

rct.Width, rct.Height);

rct := CenteredRect(pbx.ClientRect, rct);

if rbtnPng.Checked then

// Если указано, просто рисуем PNG-исходник

StretchDraw(rct, Image1.Picture.Graphic)

else

begin

tmp := TBitmap.Create;

try

tmp.Assign(Image1.Picture.Graphic);

if rbtnNew.Checked then

// Формируем PNG по-новому

png := BitmapToPNG(tmp)

else

// Формируем PNG по-старому

png := BitmapToPNG(tmp, nil);

try

StretchDraw(rct, png)

finally

png.Free;

end;

finally

tmp.Free;

end;

end

else

begin

// Получить пропорциональный размерам окна прямоугольник

rct := GetProportRect(GetImageRect(src),

rct.Width, rct.Height);

// Отцентрировать его

rct := CenteredRect(pbx.ClientRect, rct);

// Если сравнивать не требуется, просто рисуем

StretchDraw(rct, src);

end;

Brush.Style := bsClear;

Pen.Color := clBtnShadow;

Rectangle(ClipRect);

end;

pbx.Canvas.Draw(0, 0, bmp);

finally

FreeAndNil(bmp);

FreeAndNil(src);

end;

Здесь мы воспользовались функцией LoadBitmapFromGraphic из способа 1. Мы преобразовали TGraphic, который находится в Image2, в Bitmap. Затем сделали его полностью прозрачным функцией SetBitmapAlpha. Потом перенесли альфа-канал из ранее подготовленного PNG функцией SetPngAlphaToBitmap. И только после всех манипуляций с альфа-каналом установили формат AlphaFormat = afDefined.

В демо-приложении реализован режим сравнения: можно переключаться между отрисовкой исходного PNG, результатом старой функции BitmapToPNG (с двумя параметрами) и новой (с одним), чтобы увидеть разницу — в частности, серую окантовку при premultiplied-данных.

Скачать

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

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

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

Примечание: в 64-битной сборке (Delphi 13.0 Florence) выбор старого метода конвертации вызовет Access Violation — именно тот баг с PByte(Integer(d)), описанный в статье. Исключение штатно перехватывается блоком try…except. Старая функция намеренно оставлена без исправлений для наглядной демонстрации проблемы.

5 7 голоса

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

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

Старые

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

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

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

Олег

4 лет назад

Роман, весьма полезная статья! Благодарю, пригодится в хозяйстве.

Ответить

Roman

Автор

Ответить на Олег

4 лет назад

Спасибо! Не за что. Хорошо, что пригодится ))) Хороших песен есть у нас.

Ответить