Стандартными средствами Delphi можно создать PNG из Bitmap, но альфа канал при этом не переносится. Что за PNG без альфа-канала? Исправим это вопиющее безобразие. Заодно рассмотрим нюансы получения Bitmap из TGraphic.
PNG из Bitmap
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 |
// Конвертировать TBitmap в TPNGImage с переносом альфа-канала function BitmapToPNG(const ABitmap: TBitmap; const APNG: TPNGImage = nil): TPNGImage; 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; |
Если требуются пояснения по коду, пишите в комментариях, с удовольствием отвечу.
Перенос альфа-канала из PNG в Bitmap
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 |
// Перенести альфа-канал из PNG в растровое изображение, // подразумевается, что bitmap - это копия PNG function SetPngAlphaToBitmap(const AImage: TPngImage; const ABitmap: TBitmap): TBitmap; var y,x: Integer; start: Integer; dst: PRGBQuad; src: pByte; begin Result := ABitmap; if not Assigned(Result) or (Result.PixelFormat <> pf32bit) or (Result.Height < 1) then Exit; AImage.CreateAlpha; start := DWORD(Result.ScanLine[0]); for y := 0 to AImage.Height-1 do begin if y >= ABitmap.Height then Break; src := @(AImage.AlphaScanline[y]^[0]); dst := PRGBQuad(start - y*Result.Width*4); for x := 0 to AImage.Width-1 do begin if x < ABitmap.Width then begin dst^.rgbReserved := src^; inc(dst) end; inc(src); end; end; end; |
Переносить альфа-канал можно на что угодно. Например, у нас есть PNG с чуть размытым по Гауссу содержимым.

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

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

Получить Bitmap из TGraphic. Способ 1
Битмап в графике нужен всегда. Для обработки и анализа изображения. Для переноса данных из одного формата в другой. Просто для отрисовки. Все графические форматы рисуют не себя, а битмап, который формируется на основании данных, хранящихся в нем.
Не всегда графический формат согласен отдать свой внутренний битмап. Использование Assign также может не дать желаемого результата. Поэтому будем просто рисовать на битмапе искомый TGraphic.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 |
// Создать TBitmap из TGraphic // Если AMaxWidth > 0, будет вычислен пропорциональный размер и // отмасштабирован с помощью GDI (т.е. без особых бикубичностей) function LoadBitmapFromGraphic(const AGraphic: TGraphic; const AMaxWidth: Integer = -1): TBitmap; var Stretch: boolean; begin Result := nil; if (not Assigned(AGraphic)) then Exit; 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; |
Почему закомментирован вызов SetPngAlphaToBitmap. Потому что не всегда нужно переносить альфа-канал. Если это необходимо, вполне можно вызвать после LoadBitmapFromGraphic.
Для работы с альфа-каналом у нас есть отдельная функция.
Получить Bitmap из TGraphic. Способ 2. Альфа-канал
Метод Assign для потомков TGraphic вещь универсальная. В силу этого не всегда делает то, что хочется. Поэтому чуть модифицируем и дополним.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 |
// Установить все альфа-байты в указанное значение function SetBitmapAlpha(const ABitmap: TBitmap; const Alpha: Byte=255): TBitmap; var i,c: Integer; s: PRGBQuad; begin Result := ABitmap; if (Result.PixelFormat <> pf32bit) or (Result.Height<1) then Exit; s := ABitmap.ScanLine[ABitmap.Height-1]; c := ABitmap.Width * ABitmap.Height - 1; for i := 0 to c do begin s^.rgbReserved := Alpha; inc(s) end; end; // Если есть хотя бы один альфа-байт <> 0, результат TRUE function CheckBitmapAlpha(const ABitmap: TBitmap): Boolean; var i,c: Integer; s: PRGBQuad; begin Result := Assigned(ABitmap) and (ABitmap.PixelFormat = pf32bit) and (ABitmap.Height>0); if not Result then Exit; s := ABitmap.ScanLine[ABitmap.Height-1]; c := ABitmap.Width * ABitmap.Height - 1; Result := False; for i := 0 to c do begin Result := (s^.rgbReserved <> 0); if Result then Exit; inc(s) end; end; // Создать bitmap из TGraphic методом Assign function LoadBitmapFromGraphic (const AGraphic: TGraphic; const APixelFormat: TPixelFormat = pf32Bit): TBitmap; begin Result := nil; if (not Assigned(AGraphic) or AGraphic.Empty) then Exit; Result := TBitmap.Create; 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; end; |
Почему закомментирована последняя строка. Свойство AlphaFormat следует устанавливать после всех операция с альфа-байтами. После вызова функции LoadBitmapFromGraphic, возможно, захочется еще что-то поделать с битмапом. Если свойство AlphaFormat уже будет выставлено, результаты будут крайне забавными.
Что тут происходит. Дело в том, что достаточно часто возникает ситуация, когда мы применили Assign, сделали PixelFormat = pf32bit и выставили AlphaFormat = afDefined, и в результате при отрисовке видим… пустоту! Чистый лист. Нетронутый холст. Такое ощущение, что произошла ошибка.
Но ошибки нет. Просто у нас везде альфа-канал равен 0. Непрозрачная исходная картинка, альфа-канала в ней нет. Мы перенесли данные и заказав 32 бита получили в 4-м байте пикселя 0. То есть прозрачный пиксель. И рисует все правильно — просто битмап абсолютно прозрачный.
Поэтому делаем проверку. Если у нас все альфа-байты в битмапе нулевые — это однозначно непрозрачная картинка. Если это так, выставляем все альфа-байты в 255.
Пример использования
У нас есть два TImage. Image1 отвечает за прозрачный PNG, Image2 — за фон. Открываем графические файлы и вставляем из буфера как было описано ранее.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 |
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); FPNG := TPngImage.Create; if AGraphic is TPngImage then FPNG.Assign(AGraphic) else begin bmp := LoadBitmapFromGraphic(AGraphic, pf32bit); try FPNG := BitmapToPNG(bmp, FPNG); finally FreeAndNil(bmp); end; end; FPNG.CreateAlpha; end; //... pbPaint(pb); end; |
Полный текст лучше посмотреть в исходниках по ссылке ниже. Что тут происходит. Если в Image1 находится TPNGImage, то используем Assign. Если что-то другое, а при вставке из буфера нам прилетает TBitmap, используем LoadBitmapFromGraphic из способа 2.
Обработчик события OnPaint компонента pb: TPaintBox выглядит следующим образом:
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 |
procedure TFmMain.pbPaint(Sender: TObject); var bmp: TBitmap; rct: Trect; pbx: TPaintBox; src: TBitmap; 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); try // если не 32 бита, две следующие функции с таким // битмапом работать не будут src.PixelFormat := pf32Bit; // сделать картинку полностью прозрачной src := SetBitmapAlpha(src,0); // перенос альфа-канала src := SetPngAlphaToBitmap(FPNG, src); // в конце, установка альфа формата src.AlphaFormat := afDefined; // получить пропорциональный размерам окна прямоугольник rct := GetProportRect(GetImageRect(src), rct.Width, rct.Height); // отцентрировать его rct := CenterInRect(pbx.ClientRect, rct); with bmp.Canvas do begin Brush.Color := clWhite; FillRect(ClipRect); StretchDraw(rct,src); end; finally pbx.Canvas.Draw(0,0,bmp); FreeAndNil(bmp); FreeAndNil(src); end; end; |
Здесь мы воспользовались функцией LoadBitmapFromGraphic из способа 1. Мы преобразовали TGraphic, который находится в Image2, в Bitmap. Затем сделали его полностью прозрачным функцией SetBitmapAlpha. Потом перенесли альфа-канал из ранее подготовленного PNG функцией SetPngAlphaToBitmap. И только после всех манипуляция с альфа-каналом установили формат AlphaFormat = afDefined.
В конце просто нарисовали этот битмап.
Таким образом, протестирована работа функций:
- BitmapToPNG — сделать PNG из Bitmap с переносом альфа-канала;
- SetPngAlphaToBitmap — перенос альфа-канала из PNG в Bitmap;
- LoadBitmapFromGraphic 1 — получить Bitmap из TGraphic с масштабированием;
- LoadBitmapFromGraphic 2 — получить Bitmap из TGraphic с анализом альфа-канала;
Скачать
Cпасибо за внимание!
Надеюсь, материал был полезен.
Подписывайтесь на телегу, задавайте вопросы, пишите комментарии.
Отвечу на все вопросы, выслушаю любую конструктивную критику.
Исходники (Delphi XE 7-10) 282 Кб
Исполняемый файл (zip) 1.18 Мб
Роман, весьма полезная статья! Благодарю, пригодится в хозяйстве.
Спасибо! Не за что. Хорошо, что пригодится ))) Хороших песен есть у нас.