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; Dest: TPngImage);
procedure CreatePNG(Color, Mask: TBitmap; Dest: TPngImage; InverseMask: Boolean = False);
procedure CreatePNGMasked(Bitmap: TBitmap; Mask: TColor; 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);
  { Performance optimized version without floating point operations by Christian Budde }
  var
    X: Byte;
  begin
    X := (R * 77 + G * 150 + B * 29) shr 8;
    R := ((R * (255 - Amount)) + (X * Amount) + 128) shr 8;
    G := ((G * (255 - Amount)) + (X * Amount) + 128) shr 8;
    B := ((B * (255 - Amount)) + (X * Amount) + 128) shr 8;
    (* original code
    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; Dest: TPngImage);
var
  MaskLines: array of pngimage.PByteArray;

  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
    TBitmapInfoV4 = packed record
      bmiHeader: TBitmapV4Header; //Otherwise I may not get per-pixel alpha values.
      bmiColors: array[0..2] of TRGBQuad; // reserve space for color lookup table
    end;
  var
    Bits: PRGBALine;
    { The BitmapInfo parameter to GetDIBits is delared as var parameter. So instead of casting around, we simply use
      the absolute directive to refer to the same memory area. }
    BitmapInfo: TBitmapInfoV4;
    BitmapInfoFake: TBitmapInfo absolute BitmapInfo;
    I, X, Y: Integer;
    HasAlpha: Boolean;
    BitsSize: Integer;
    bmpDC: HDC;
    bmpHandle: HBITMAP;
  begin
    BitsSize := 4 * SourceColor.Width * SourceColor.Height;
    Bits := AllocMem(BitsSize);
    try
      FillChar(BitmapInfo, SizeOf(BitmapInfo), 0);
      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;
      BitmapInfo.bmiColors[0].rgbRed := 255;
      BitmapInfo.bmiColors[1].rgbGreen := 255;
      BitmapInfo.bmiColors[2].rgbBlue := 255;

      { Getting the bitmap Handle will invalidate the Canvas.Handle, so it is important to retrieve them in the correct
        order. As parameter evaluation order is undefined and differs between Win32 and Win64, we get invalid values
        for Canvas.Handle when we use those properties directly in the call to GetDIBits. }
      bmpHandle := SourceColor.Handle;
      bmpDC := SourceColor.Canvas.Handle;
      if GetDIBits(bmpDC, bmpHandle, 0, SourceColor.Height, Bits, BitmapInfoFake, 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
  Assert(Dest <> nil, 'Dest is nil!');
  //A PNG does not have to be converted
  if Source is TPngImage then begin
    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, assign the destination PNG image
    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; Dest: TPngImage; InverseMask: Boolean = False);
var
  Temp: TBitmap;
  Line: pngimage.PByteArray;
  X, Y: Integer;
begin
  Assert(Dest <> nil, 'Dest is nil!');
  //Create a PNG from two separate color and mask bitmaps. InverseMask should be
  //True if white means transparent, and black means opaque.
  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; Dest: TPngImage);
var
  Temp: TBitmap;
  Line: pngimage.PByteArray;
  X, Y: Integer;
begin
  Assert(Dest <> nil, 'Dest is nil!');
  //Create a PNG from two separate color and mask bitmaps. InverseMask should be
  //True if white means transparent, and black means opaque.
  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.