unit PngFunctions;

interface

uses
  Windows, Graphics, ImgList, Contnrs, pngimage;

{$IF RTLVersion < 20.0 }
  {$IF RTLVersion < 15.0 }
    PngComponents are only compatible with Delphi 7 and higher!
  {$IFEND}
type
  TPngImage = TPNGObject;
{$IFEND}

type
  TPngOption = (pngBlendOnDisabled, pngGrayscaleOnDisabled);
  TPngOptions = set of TPngOption;
  TRGBLine = array[Word] of TRGBTriple;
  PRGBLine = ^TRGBLine;
  TRGBALine = array[Word] of TRGBQuad;
  PRGBALine = ^TRGBALine;

procedure MakeImageBlended(Image: TPngImage; Amount: Byte = 127);
procedure MakeImageGrayscale(Image: TPngImage; Amount: Byte = 255);
procedure DrawPNG(Png: TPngImage; Canvas: TCanvas; const ARect: TRect; const Options: TPngOptions);
procedure ConvertToPNG(Source: TGraphic; out Dest: TPngImage);
procedure CreatePNG(Color, Mask: TBitmap; out Dest: TPngImage; InverseMask: Boolean = False);
procedure CreatePNGMasked(Bitmap: TBitmap; Mask: TColor; out Dest: TPngImage);
procedure CopyImageFromImageList(Dest: TPngImage; ImageList: TCustomImageList; Index: Integer);
procedure SlicePNG(JoinedPNG: TPngImage; Columns, Rows: Integer; out SlicedPNGs: TObjectList);

implementation

uses
  SysUtils, PngImageList;

function ColorToTriple(Color: TColor): TRGBTriple;
var
  ColorRGB: Longint;
begin
  ColorRGB := ColorToRGB(Color);
  Result.rgbtBlue := ColorRGB shr 16 and $FF;
  Result.rgbtGreen := ColorRGB shr 8 and $FF;
  Result.rgbtRed := ColorRGB and $FF;
end;

procedure MakeImageBlended(Image: TPngImage; Amount: Byte = 127);

  procedure ForceAlphachannel(BitTransparency: Boolean; TransparentColor: TColor);
  var
    Assigner: TBitmap;
    Temp: TPngImage;
    X, Y: Integer;
    Line: pngimage.PByteArray;
    Current: TColor;
  begin
    //Not all formats of PNG support an alpha-channel (paletted images for example),
    //so with this function, I simply recreate the PNG as being 32-bits, effectivly
    //forcing an alpha-channel on it.
    Temp := TPngImage.Create;
    try
      Assigner := TBitmap.Create;
      try
        Assigner.Width := Image.Width;
        Assigner.Height := Image.Height;
        Temp.Assign(Assigner);
      finally
        Assigner.Free;
      end;
      Temp.CreateAlpha;
      for Y := 0 to Image.Height - 1 do begin
        Line := Temp.AlphaScanline[Y];
        for X := 0 to Image.Width - 1 do begin
          Current := Image.Pixels[X, Y];
          Temp.Pixels[X, Y] := Current;
          if BitTransparency and (Current = TransparentColor) then
            Line[X] := 0
          else
            Line[X] := Amount;
        end;
      end;
      Image.Assign(Temp);
    finally
      Temp.Free;
    end;
  end;

var
  X, Y: Integer;
  Line: pngimage.PByteArray;
  Forced: Boolean;
  TransparentColor: TColor;
  BitTransparency: Boolean;
begin
  //If the PNG doesn't have an alpha channel, then add one
  BitTransparency := Image.TransparencyMode = ptmBit;
  TransparentColor := Image.TransparentColor;
  Forced := False;
  if not (Image.Header.ColorType in [COLOR_RGBALPHA, COLOR_GRAYSCALEALPHA]) then begin
    Forced := Image.Header.ColorType in [COLOR_GRAYSCALE, COLOR_PALETTE];
    if Forced then
      ForceAlphachannel(BitTransparency, TransparentColor)
    else
      Image.CreateAlpha;
  end;

  //Divide the alpha values by 2
  if not Forced and (Image.Header.ColorType in [COLOR_RGBALPHA, COLOR_GRAYSCALEALPHA]) then begin
    for Y := 0 to Image.Height - 1 do begin
      Line := Image.AlphaScanline[Y];
      for X := 0 to Image.Width - 1 do begin
        if BitTransparency and (Image.Pixels[X, Y] = TransparentColor) then
          Line[X] := 0
        else
          Line[X] := Round(Line[X] / 256 * (Amount + 1));
      end;
    end;
  end;
end;

procedure MakeImageGrayscale(Image: TPngImage; Amount: Byte = 255);

  procedure GrayscaleRGB(var R, G, B: Byte);
  var
    X: Byte;
  begin
    X := Round(R * 0.30 + G * 0.59 + B * 0.11);
    R := Round(R / 256 * (256 - Amount - 1)) + Round(X / 256 * (Amount + 1));
    G := Round(G / 256 * (256 - Amount - 1)) + Round(X / 256 * (Amount + 1));
    B := Round(B / 256 * (256 - Amount - 1)) + Round(X / 256 * (Amount + 1));
  end;

var
  X, Y, PalCount: Integer;
  Line: PRGBLine;
  PaletteHandle: HPalette;
  Palette: array[Byte] of TPaletteEntry;
begin
  //Don't do anything if the image is already a grayscaled one
  if not (Image.Header.ColorType in [COLOR_GRAYSCALE, COLOR_GRAYSCALEALPHA]) then begin
    if Image.Header.ColorType = COLOR_PALETTE then begin
      //Grayscale every palette entry
      PaletteHandle := Image.Palette;
      PalCount := GetPaletteEntries(PaletteHandle, 0, 256, Palette);
      for X := 0 to PalCount - 1 do
        GrayscaleRGB(Palette[X].peRed, Palette[X].peGreen, Palette[X].peBlue);
      SetPaletteEntries(PaletteHandle, 0, PalCount, Palette);
      Image.Palette := PaletteHandle;
    end
    else begin
      //Grayscale every pixel
      for Y := 0 to Image.Height - 1 do begin
        Line := Image.Scanline[Y];
        for X := 0 to Image.Width - 1 do
          GrayscaleRGB(Line[X].rgbtRed, Line[X].rgbtGreen, Line[X].rgbtBlue);
      end;
    end;
  end;
end;

procedure DrawPNG(Png: TPngImage; Canvas: TCanvas; const ARect: TRect; const Options: TPngOptions);
var
  PngCopy: TPngImage;
begin
  if Options <> [] then begin
    PngCopy := TPngImage.Create;
    try
      PngCopy.Assign(Png);
      if pngBlendOnDisabled in Options then
        MakeImageBlended(PngCopy);
      if pngGrayscaleOnDisabled in Options then
        MakeImageGrayscale(PngCopy);
      PngCopy.Draw(Canvas, ARect);
    finally
      PngCopy.Free;
    end;
  end
  else begin
    Png.Draw(Canvas, ARect);
  end;
end;

procedure ConvertToPNG(Source: TGraphic; out Dest: TPngImage);
var
  MaskLines: array of pngimage.PByteArray;

  function CompareColors(const Color1: TRGBTriple; const Color2: TColor): Boolean;
  begin
    Result := (Color1.rgbtBlue = Color2 shr 16 and $FF) and
      (Color1.rgbtGreen = Color2 shr 8 and $FF) and
      (Color1.rgbtRed = Color2 and $FF);
  end;

  function ColorToTriple(const Color: TColor): TRGBTriple;
  begin
    Result.rgbtBlue := Color shr 16 and $FF;
    Result.rgbtGreen := Color shr 8 and $FF;
    Result.rgbtRed := Color and $FF;
  end;

  procedure GetAlphaMask(SourceColor: TBitmap);
  type
    TBitmapInfo = packed record
      bmiHeader: TBitmapV4Header;
      //Otherwise I may not get per-pixel alpha values.
      bmiColors: array[0..0] of TRGBQuad;
    end;
  var
    Bits: PRGBALine;
    BitmapInfo: TBitmapInfo;
    I, X, Y: Integer;
    HasAlpha: Boolean;
    BitsSize: Integer;
  begin
    BitsSize := 4 * SourceColor.Width * SourceColor.Height;
    Bits := AllocMem(BitsSize);
    try
      ZeroMemory(Bits, BitsSize);
      ZeroMemory(@BitmapInfo, SizeOf(BitmapInfo));
      BitmapInfo.bmiHeader.bV4Size := SizeOf(BitmapInfo.bmiHeader);
      BitmapInfo.bmiHeader.bV4Width := SourceColor.Width;
      BitmapInfo.bmiHeader.bV4Height := -SourceColor.Height;
      //Otherwise the image is upside down.
      BitmapInfo.bmiHeader.bV4Planes := 1;
      BitmapInfo.bmiHeader.bV4BitCount := 32;
      BitmapInfo.bmiHeader.bV4V4Compression := BI_BITFIELDS;
      BitmapInfo.bmiHeader.bV4SizeImage := BitsSize;

      if GetDIBits(SourceColor.Canvas.Handle, SourceColor.Handle, 0,
        SourceColor.Height, Bits, Windows.PBitmapInfo(@BitmapInfo)^,
        DIB_RGB_COLORS) > 0 then begin
        //Because Win32 API is a piece of crap when it comes to icons, I have to check
        //whether an has an alpha-channel the hard way.
        HasAlpha := False;
        for I := 0 to (SourceColor.Height * SourceColor.Width) - 1 do begin
          if Bits[I].rgbReserved <> 0 then begin
            HasAlpha := True;
            Break;
          end;
        end;
        if HasAlpha then begin
          //OK, so not all alpha-values are 0, which indicates the existence of an
          //alpha-channel.
          I := 0;
          for Y := 0 to SourceColor.Height - 1 do
            for X := 0 to SourceColor.Width - 1 do begin
              MaskLines[Y][X] := Bits[I].rgbReserved;
              Inc(I);
            end;
        end;
      end;
    finally
      FreeMem(Bits, BitsSize);
    end;
  end;

  function WinXPOrHigher: Boolean;
  var
    Info: TOSVersionInfo;
  begin
    Info.dwOSVersionInfoSize := SizeOf(Info);
    GetVersionEx(Info);
    Result := (Info.dwPlatformId = VER_PLATFORM_WIN32_NT) and
      ((Info.dwMajorVersion > 5) or
      ((Info.dwMajorVersion = 5) and (Info.dwMinorVersion >= 1)));
  end;

var
  Temp, SourceColor, SourceMask: TBitmap;
  X, Y: Integer;
  Line: PRGBLine;
  MaskLine, AlphaLine: pngimage.PByteArray;
  TransparentColor, CurrentColor: TColor;
  IconInfo: TIconInfo;
  AlphaNeeded: Boolean;
begin
  //A PNG does not have to be converted
  if Source is TPngImage then begin
    Dest := TPngImage.Create;
    Dest.Assign(Source);
    Exit;
  end;

  AlphaNeeded := False;
  Temp := TBitmap.Create;
  SetLength(MaskLines, Source.Height);
  for Y := 0 to Source.Height - 1 do begin
    MaskLines[Y] := AllocMem(Source.Width);
    FillMemory(MaskLines[Y], Source.Width, 255);
  end;
  try
    //Initialize intermediate color bitmap
    Temp.Width := Source.Width;
    Temp.Height := Source.Height;
    Temp.PixelFormat := pf24bit;

    //Now figure out the transparency
    if Source is TBitmap then begin
      if Source.Transparent then begin
        //TBitmap is just about comparing the drawn colors against the TransparentColor
        if TBitmap(Source).TransparentMode = tmFixed then
          TransparentColor := TBitmap(Source).TransparentColor
        else
          TransparentColor := TBitmap(Source).Canvas.Pixels[0, Source.Height - 1];

        for Y := 0 to Temp.Height - 1 do begin
          Line := Temp.ScanLine[Y];
          MaskLine := MaskLines[Y];
          for X := 0 to Temp.Width - 1 do begin
            CurrentColor := GetPixel(TBitmap(Source).Canvas.Handle, X, Y);
            if CurrentColor = TransparentColor then begin
              MaskLine^[X] := 0;
              AlphaNeeded := True;
            end;
            Line[X] := ColorToTriple(CurrentColor);
          end;
        end;
      end
      else begin
        Temp.Canvas.Draw(0, 0, Source);
      end;
    end
    else if Source is TIcon then begin
      //TIcon is more complicated, because there are bitmasked (classic) icons and
      //alphablended (modern) icons. Not to forget about the "inverse" color.
      GetIconInfo(TIcon(Source).Handle, IconInfo);
      SourceColor := TBitmap.Create;
      SourceMask := TBitmap.Create;
      try
        SourceColor.Handle := IconInfo.hbmColor;
        SourceMask.Handle := IconInfo.hbmMask;
        Temp.Canvas.Draw(0, 0, SourceColor);
        for Y := 0 to Temp.Height - 1 do begin
          MaskLine := MaskLines[Y];
          for X := 0 to Temp.Width - 1 do begin
            if GetPixel(SourceMask.Canvas.Handle, X, Y) <> 0 then begin
              MaskLine^[X] := 0;
              AlphaNeeded := True;
            end;
          end;
        end;
        if (GetDeviceCaps(SourceColor.Canvas.Handle, BITSPIXEL) = 32) and WinXPOrHigher then begin
          //This doesn't neccesarily mean we actually have 32bpp in the icon, because the
          //bpp of an icon is always the same as the display settings, regardless of the
          //actual color depth of the icon :(
          AlphaNeeded := True;
          GetAlphaMask(SourceColor);
        end;
        //This still doesn't work for alphablended icons...
      finally
        SourceColor.Free;
        SourceMask.Free
      end;
    end;

    //And finally, create the destination PNG image
    Dest := TPngImage.Create;
    Dest.Assign(Temp);
    if AlphaNeeded then begin
      Dest.CreateAlpha;
      for Y := 0 to Dest.Height - 1 do begin
        AlphaLine := Dest.AlphaScanline[Y];
        CopyMemory(AlphaLine, MaskLines[Y], Temp.Width);
      end;
    end;

  finally
    for Y := 0 to Source.Height - 1 do
      FreeMem(MaskLines[Y], Source.Width);
    Temp.Free;
  end;
end;

procedure CreatePNG(Color, Mask: TBitmap; out Dest: TPngImage; InverseMask: Boolean = False);
var
  Temp: TBitmap;
  Line: pngimage.PByteArray;
  X, Y: Integer;
begin
  //Create a PNG from two separate color and mask bitmaps. InverseMask should be
  //True if white means transparent, and black means opaque.
  Dest := TPngImage.Create;
  if not (Color.PixelFormat in [pf24bit, pf32bit]) then begin
    Temp := TBitmap.Create;
    try
      Temp.Assign(Color);
      Temp.PixelFormat := pf24bit;
      Dest.Assign(Temp);
    finally
      Temp.Free;
    end;
  end
  else begin
    Dest.Assign(Color);
  end;

  //Copy the alpha channel.
  Dest.CreateAlpha;
  for Y := 0 to Dest.Height - 1 do begin
    Line := Dest.AlphaScanline[Y];
    for X := 0 to Dest.Width - 1 do begin
      if InverseMask then
        Line[X] := 255 - (GetPixel(Mask.Canvas.Handle, X, Y) and $FF)
      else
        Line[X] := GetPixel(Mask.Canvas.Handle, X, Y) and $FF;
    end;
  end;
end;

procedure CreatePNGMasked(Bitmap: TBitmap; Mask: TColor; out Dest: TPngImage);
var
  Temp: TBitmap;
  Line: pngimage.PByteArray;
  X, Y: Integer;
begin
  //Create a PNG from two separate color and mask bitmaps. InverseMask should be
  //True if white means transparent, and black means opaque.
  Dest := TPngImage.Create;
  if not (Bitmap.PixelFormat in [pf24bit, pf32bit]) then begin
    Temp := TBitmap.Create;
    try
      Temp.Assign(Bitmap);
      Temp.PixelFormat := pf24bit;
      Dest.Assign(Temp);
    finally
      Temp.Free;
    end;
  end
  else begin
    Dest.Assign(Bitmap);
  end;

  //Copy the alpha channel.
  Dest.CreateAlpha;
  for Y := 0 to Dest.Height - 1 do begin
    Line := Dest.AlphaScanline[Y];
    for X := 0 to Dest.Width - 1 do
      Line[X] := Integer(TColor(GetPixel(Bitmap.Canvas.Handle, X, Y)) <> Mask) * $FF;
  end;
end;

procedure CopyImageFromImageList(Dest: TPngImage; ImageList: TCustomImageList; Index: Integer);
var
  Icon: TIcon;
  IconInfo: TIconInfo;
  ColorBitmap, MaskBitmap: TBitmap;
  X, Y: Integer;
  AlphaLine: pngimage.PByteArray;
  Png: TPngImageCollectionItem;
begin
  if ImageList is TPngImageList then begin
    //This is easy, just copy the PNG object from the imagelist to the PNG object
    //from the button
    Png := TPNGImageList(ImageList).PngImages[Index];
    if Png <> nil then
      Dest.Assign(Png.PngImage);
  end
  else begin
    Icon := TIcon.Create;
    ColorBitmap := TBitmap.Create;
    MaskBitmap := TBitmap.Create;
    try
      //Try to copy an icon to a PNG object, including transparency
      ImageList.GetIcon(Index, Icon);
      if GetIconInfo(Icon.Handle, IconInfo) then begin
        //First, pump the colors into the PNG object
        ColorBitmap.Handle := IconInfo.hbmColor;
        ColorBitmap.PixelFormat := pf24bit;
        Dest.Assign(ColorBitmap);

        //Finally, copy the transparency
        Dest.CreateAlpha;
        MaskBitmap.Handle := IconInfo.hbmMask;
        for Y := 0 to Dest.Height - 1 do begin
          AlphaLine := Dest.AlphaScanline[Y];
          for X := 0 to Dest.Width - 1 do
            AlphaLine^[X] := Integer(GetPixel(MaskBitmap.Canvas.Handle, X, Y) = COLORREF(clBlack)) * $FF;
        end;
      end;
    finally
      MaskBitmap.Free;
      ColorBitmap.Free;
      Icon.Free;
    end;
  end;
end;

procedure SlicePNG(JoinedPNG: TPngImage; Columns, Rows: Integer; out SlicedPNGs: TObjectList);
var
  X, Y, ImageX, ImageY, OffsetX, OffsetY: Integer;
  Width, Height: Integer;
  Bitmap: TBitmap;
  BitmapLine: PRGBLine;
  AlphaLineA, AlphaLineB: pngimage.PByteArray;
  PNG: TPngImage;
begin
  //This function slices a large PNG file (e.g. an image with all images for a
  //toolbar) into smaller, equally-sized pictures.
  SlicedPNGs := TObjectList.Create(False);
  Width := JoinedPNG.Width div Columns;
  Height := JoinedPNG.Height div Rows;

  //Loop through the columns and rows to create each individual image
  for ImageY := 0 to Rows - 1 do begin
    for ImageX := 0 to Columns - 1 do begin
      OffsetX := ImageX * Width;
      OffsetY := ImageY * Height;
      Bitmap := TBitmap.Create;
      try
        Bitmap.Width := Width;
        Bitmap.Height := Height;
        Bitmap.PixelFormat := pf24bit;

        //Copy the color information into a temporary bitmap. We can't use TPngImage.Draw
        //here, because that would combine the color and alpha values.
        for Y := 0 to Bitmap.Height - 1 do begin
          BitmapLine := Bitmap.Scanline[Y];
          for X := 0 to Bitmap.Width - 1 do
            BitmapLine[X] := ColorToTriple(JoinedPNG.Pixels[X + OffsetX, Y + OffsetY]);
        end;

        PNG := TPngImage.Create;
        PNG.Assign(Bitmap);

        if JoinedPNG.Header.ColorType in [COLOR_GRAYSCALEALPHA, COLOR_RGBALPHA] then begin
          //Copy the alpha channel
          PNG.CreateAlpha;
          for Y := 0 to PNG.Height - 1 do begin
            AlphaLineA := JoinedPNG.AlphaScanline[Y + OffsetY];
            AlphaLineB := PNG.AlphaScanline[Y];
            for X := 0 to PNG.Width - 1 do
              AlphaLineB[X] := AlphaLineA[X + OffsetX];
          end;
        end;

        SlicedPNGs.Add(PNG);
      finally
        Bitmap.Free;
      end;
    end;
  end;
end;

{$IF RTLVersion >= 20.0 }
type
  TPNGObject = class(TPngImage);
initialization
  TPicture.RegisterFileFormat('', '', TPNGObject);
finalization
  TPicture.UnregisterGraphicClass(TPNGObject);
{$IFEND}
end.

