Convert Png To ico fmx delphi

[xorpas 4]

Hello 

I would like to convert png or any image format To Ico  with fmx Any Help

[David Heffernan 2345]

You could search for a library with support for this. Otherwise the ico format is very simple and comprehensively documented. 

[Anders Melander 1782]

19 hours ago, David Heffernan said:

the ico format is very simple and comprehensively documented

I'm guessing you've never had to write code that can read and write icons in all of the supported formats 🙂

[Guest]

first load your png file using the timage object. then use timage's bitmap, check below code. PNG -> BMP -> ICO

If ur question is, give me a ready-made function, if you say you want a small code that automatically prepares the png and icon file,
I'm wondering that too, time should be spent.

unit Icon32;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls,
  Forms, Dialogs;

type
  ByteArray = array of Byte;
  TIcon32FileString = type string;
  TBlendMode = (bmColor, bmAlpha);
  TIconSize = (is16,is24,is32,is48);

  TIcon32 = class(TGraphicControl)
  private
    FData      : PByteArray;
    FDataSize  : Integer;
    FIcon32Name: TIcon32FileString;
    FBMP       : TBitmap;
    FBlendMode : TBlendMode;
    FBGColor	 : TColor;
    FIconSize  : TIconSize;
    FUpdate    : boolean;
    procedure WriteData(Stream: TStream);
    procedure ReadData(Stream: TStream);

    procedure SetBGColor(const Value: TColor);
    procedure SetBlendMode(const Value: TBlendMode);
    procedure SetIconSize(const Value: TIconSize);
    procedure SetIcon32Name(const Value: TIcon32FileString);
  protected
    procedure DefineProperties(Filer: TFiler); override;
  public
    constructor Create(AOwner : TComponent); override;
    destructor Destroy; override;
    procedure Paint; override;
    function Empty: Boolean;
    procedure LoadFromFile(const FileName: String);
    procedure LoadFromStream(S: TStream);
    procedure SaveToFile(const FileName: String);
    procedure SaveToStream(S: TStream);
    procedure LoadBMP;
    function Equal(Ico: TIcon32): Boolean;
  published
    property Icon32Name : TIcon32FileString read FIcon32Name write SetIcon32Name;
    property BGColor: TColor read FBGColor Write SetBGColor default clBtnface;
    property BlendMode: TBlendMode read FBlendMode Write SetBlendMode default bmColor;
    property IconSize: TIconSize read FIconSize Write SetIconSize default is32;
  end;

function BlendColors(const Color1, Color2: TColor; Amount: Extended): TColor;

procedure Register;

implementation

{ TIcon32 }

procedure Register;
begin
  RegisterComponents('Icon32', [TIcon32]);
end;

constructor TIcon32.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle := ControlStyle + [csOpaque];
  FBMP   := TBitmap.Create;
  FBGColor := clBtnFace;
  FIconSize := is32;
  Width  := 32;
  Height := 32;
  FUpdate := True;
  FDataSize := 0;
end;

procedure TIcon32.DefineProperties(Filer: TFiler);
  function DoWrite: Boolean;
  begin
    if Filer.Ancestor <> nil then
      Result := not (Filer.Ancestor is TIcon32) or
        not Equal(TIcon32(Filer.Ancestor))
    else
      Result := not Empty;
  end;

begin
  inherited DefineProperties(Filer);
  Filer.DefineBinaryProperty('Data', ReadData, WriteData, DoWrite);
end;

destructor TIcon32.Destroy;
begin
  if not Empty then
    FreeMem(FData, FDataSize);

  FBMP.Free;
  inherited;
end;

function StreamsEqual(S1, S2: TMemoryStream): Boolean;
begin
  Result := (S1.Size = S2.Size) and CompareMem(S1.Memory, S2.Memory, S1.Size);
end;

function TIcon32.Empty: Boolean;
begin
  Result := FDataSize = 0;
end;

function TIcon32.Equal(Ico: TIcon32): Boolean;
var
  MyImage, WavImage: TMemoryStream;
begin
  Result := (Ico <> nil) and (ClassType = Ico.ClassType);
  if Empty or Ico.Empty then
  begin
    Result := Empty and Ico.Empty;
    Exit;
  end;
  if Result then
  begin
    MyImage := TMemoryStream.Create;
    try
      SaveToStream(MyImage);
      WavImage := TMemoryStream.Create;
      try
        Ico.SaveToStream(WavImage);
        Result := StreamsEqual(MyImage, WavImage);
      finally
        WavImage.Free;
      end;
    finally
      MyImage.Free;
    end;
  end;
end;

procedure TIcon32.LoadBMP;
var
    i, x, y, DataSize, bw, bs : Integer;
    BPP : Byte;
    col : TColor;
    bmp2 : TBitmap;
    dc : HDC;
    cp : TPoint;
begin
   if FDataSize < 1 then
      Exit;

   BPP := FData^[12];

   if BPP <> 32 then
   begin
      MessageDlg('Invalid icon',mtError,[mbOk],0);
      FIcon32Name := '';

      if not Empty then
         FreeMem(FData, FDataSize);

      FDataSize := 0;
      Exit;
   end;

   DataSize := FData^[14] + (FData^[15] shl 8) + (FData^[16] shl 16) + (FData^[17] shl 24);
   bw       := FData^[26] + (FData^[27] shl 8) + (FData^[28] shl 16) + (FData^[29] shl 24);
   bs       := FData^[42] + (FData^[43] shl 8) + (FData^[44] shl 16) + (FData^[45] shl 24);

   case bw of
      16 : IconSize := is16;
      24 : IconSize := is24;
      32 : IconSize := is32;
      48 : IconSize := is48;
   end; // Case

   if bs < 100 then
      bs := DataSize - 104;

   FBMP.Width := FData^[6];
   FBMP.Height := FData^[6];

   bmp2 := TBitmap.Create;
   try
      bmp2.Width := FBMP.Width;
      bmp2.height := FBMP.Height;

      Self.Visible := False;
      Self.Invalidate;

      dc := GetDc(0);

      cp := Self.ClientToScreen(cp);

      try
         bitblt ( bmp2.Canvas.Handle, 0, 0, bw, bw, dc,
                  cp.X,
                  cp.Y,
                  SRCCOPY );

         x := 0; y := bw-1;
         i := 62;
         while i < bs + 62 do
         begin
            col := RGB(FData^[i+2],FData^[i+1],FData^[i]);

            if BPP = 32 then
            begin
               if FBlendMode = bmColor then
                  col := BlendColors ( FBGColor, RGB( FData^[i+2],
                                                      FData^[i+1],
                                                      FData^[i]),
                                       FData^[i+3] / 256)
               else
                  col := BlendColors ( bmp2.Canvas.Pixels[x,y], RGB( FData^[i+2],
                                                                     FData^[i+1],
                                                                     FData^[i]),
                                       FData^[i+3] / 256);
            end;

            FBMP.Canvas.Pixels[x,y] := col;

            Inc(i,BPP div 8);
            Inc(x);
            if x > bw-1 then
            begin
               x := 0;
               Dec(y);
            end;
            if y = -1 then
               break;
         end;
      finally
         ReleaseDC (0, dc);
      end;
   finally
      bmp2.Free;
   end;
   Self.Visible := true;
   Invalidate;
end;

procedure TIcon32.LoadFromFile(const FileName: String);
var
  F: TFileStream;
begin
  F := TFileStream.Create(FileName, fmOpenRead);
  try
    LoadFromStream(F);
  finally
    F.Free;
  end;
end;

procedure TIcon32.LoadFromStream(S: TStream);
begin
  if not Empty then
    FreeMem(FData, FDataSize);

  FDataSize := 0;
  GetMem(FData, S.Size);
  FDataSize := S.Size;

  S.Read(FData^, FDataSize);

  LoadBMP;
end;

procedure TIcon32.Paint;
begin
  inherited;
  if FBlendMode = bmAlpha then begin
    if FUpdate then begin
    	LoadBMP;
      FUpdate := False;
    end;
  end;
  Canvas.Draw(0,0,FBMP);
end;

procedure TIcon32.ReadData(Stream: TStream);
begin
  LoadFromStream(Stream);
end;

procedure TIcon32.SaveToFile(const FileName: String);
var
  F: TFileStream;
begin
  F := TFileStream.Create(FileName, fmCreate);
  try
    SaveToStream(F);
  finally
    F.Free;
  end;
end;

procedure TIcon32.SaveToStream(S: TStream);
begin
  if not Empty then
    S.Write(FData^, FDataSize);
end;

procedure TIcon32.SetBGColor(const Value: TColor);
begin
  FBGColor := Value;
  if FIcon32Name <> '' then LoadBMP;
end;

procedure TIcon32.SetBlendMode(const Value: TBlendMode);
begin
  FBlendMode := Value;
  if FIcon32Name <> '' then LoadBMP;
end;

procedure TIcon32.SetIcon32Name(const Value: TIcon32FileString);
begin
  if Value <> '' then begin
    if not FileExists(Value) then Exit;
    FIcon32Name := ExtractFileName(Value);
    if (not (csLoading in ComponentState)) and FileExists(Value) then
      LoadFromFile(Value);
  end
  else begin
    FIcon32Name := '';
    if not Empty then
      FreeMem(FData, FDataSize);
    FDataSize := 0;
  end;
end;

procedure TIcon32.SetIconSize(const Value: TIconSize);
begin
  FIconSize := Value;
  case Value of
    is16 : 	begin
              Width  := 16;
              Height := 16;
            end;
    is24 : 	begin
              Width  := 24;
              Height := 24;
            end;
    is32 : 	begin
              Width  := 32;
              Height := 32;
            end;
    is48 : 	begin
              Width  := 48;
              Height := 48;
            end;
  end;
end;

function BlendColors(const Color1, Color2: TColor; Amount: Extended): TColor;
var
  R,R2,G,G2,B,B2: Integer;
  win1, win2: Integer;
begin
  win1 := ColorToRGB(color1);
  win2 := ColorToRGB(color2);

  R := GetRValue(win1);
  G := GetGValue(win1);
  B := GetBValue(win1);

  R2 := GetRValue(win2);
  G2 := GetGValue(win2);
  B2 := GetBValue(win2);

  b2:=round((1-amount)*b+amount*b2);
  g2:=round((1-amount)*g+amount*g2);
  r2:=round((1-amount)*r+amount*r2);

  if R2 < 0 then R2 := 0;
  if G2 < 0 then G2 := 0;
  if B2 < 0 then B2 := 0;

  if R2 > 255 then R2 := r;
  if G2 > 255 then G2 := r;
  if B2 > 255 then B2 := r;

  Result := TColor(RGB(R2, G2, B2));
end;

procedure TIcon32.WriteData(Stream: TStream);
begin
  SaveToStream(Stream);
end;

end.

 

Edited January 27, 2023 by Guest

[xorpas 4]

Thank you mr  okoca for report all code thank's But I need it for fmx

Edited January 27, 2023 by xorpas

[David Heffernan 2345]

8 hours ago, Anders Melander said:

I'm guessing you've never had to write code that can read and write icons in all of the supported formats 🙂

We don't need to read the files, and we don't need to write in all supported formats. I guess the only real complication I can see here is the PNG format for 256px images. 

[Anders Melander 1782]

20 minutes ago, David Heffernan said:

I guess the only real complication I can see here is the PNG format for 256px images.

Actually, IME, the PNG sub-format is the least troublesome; It just has a PNG file instead of the regular BMP pixel data. No, it's the non-alpha formats, and in particular, the 1 bpp format, that is the worst.

 

If the task here is to convert a PNG to an ICO I would just create an ICO header with a single 32bpp PNG sub-image and then simply use the PNG as-is for the sub-image.

Something like this (not tested):

const
  RES_ICON = 1;
  RES_CURSOR = 2;
  
type
  TIconDirectoryHeader = packed record
    Reserved: Word;             // Reserved; must be zero.

    ResType: Word;              // Specifies the resource type. This member must
                                // have one of the following values:
                                //   RES_ICON      Icon resource type.
                                //   RES_CURSOR    Cursor resource type.

    ResCount: Word;             // Specifies the number of icon or cursor
                                // components in the resource group.
  end;

  TIconDirectoryEntry = packed record
    Width: Byte;
    Height: Byte;
    ColorCount: Byte;
    Reserved: Byte;
    ResInfo: packed record
    case byte of
      RES_ICON: (
        IconPlanes: Word;
        IconBitCount: Word);
      RES_CURSOR: (
        CursorHotspotX: Word;
        CursorHotspotY: Word);
    end;
    BytesInRes: DWORD;
    ImageOffset: DWORD;
  end;

  TColorDepth = 1..32; // Bits per pixel. Not bits per plane.

function ColorDepthToColors(ColorDepth: TColorDepth): cardinal;
begin
  Result := 1;
  while (ColorDepth > 0) do
  begin
    Result := Result shl 1;
    dec(ColorDepth);
  end;
end;

// PngStream:	A stream containing the PNG
// IcoStream:	The outout stream
// AWidth:		Width of the PNG
// AHeight:		Height of the PNG
// AColorDepth:	Color depth of the PNG
procedure SavePngStreamToIcoStream(PngStream, IcoStream: TStream; AWidth, AHeight: integer; AColorDepth: TColorDepth = 32);
begin
  var IconDirectoryHeader: TIconDirectoryHeader := Default(TIconDirectoryHeader);
  var IconDirectoryEntry: TIconDirectoryEntry := Default(TIconDirectoryEntry);
  
  IconDirectoryHeader.ResType := RES_ICON;
  IconDirectoryHeader.ResCount := 1;
  
  IcoStream.Write(IconDirectoryHeader, SizeOf(IconDirectoryHeader));

  // Note : 256x256 icon sets Width&Height to 0 (according to docs) or to 255 (according to .NET)
  IconDirectoryEntry.Width := AWidth and $FF;
  IconDirectoryEntry.Height := AHeight and $FF;

  var BitCount := 0;
  var ColorCount := 0;
  case AColorDepth of
    1, 4: ColorCount := ColorDepthToColors(AColorDepth);
  else
    BitCount := AColorDepth;
  end;

  IconDirectoryEntry.BytesInRes := PngStream.Size;
  IconDirectoryEntry.ImageOffset := SizeOf(IconDirectoryHeader) + SizeOf(IconDirectoryEntry);
  IconDirectoryEntry.ResInfo.IconPlanes := 1;
  IconDirectoryEntry.ResInfo.IconBitCount := BitCount;
  IconDirectoryEntry.ColorCount := ColorCount;
  
  IcoStream.Write(IconDirectoryEntry, SizeOf(IconDirectoryEntry));
  
  IcoStream.CopyFrom(PngStream, 0);
end;

 

[programmerdelphi2k 237]

great Melander... better than pointing to infinity, is showing where it probably starts. 

 

  that way we can fix the path at any time!  (better than being left in doubt by inconclusive answers)

Edited January 27, 2023 by programmerdelphi2k

[Patrick PREMARTIN 69]

Hi

If you want to generate ICO exe files, you can search "Export en format ICO" text in https://github.com/DeveloppeurPascal/PicMobGenerator/blob/main/src/fMain.pas 

You'll see how I managed it for Pic Mob Generator program I've just open sourced to answer you (it was on my todo list for 2023, thanks for giving me a reason to do it).

 

[ZDeveloper 2]

easy mainicon tool generator 

https://convertico.com/

[Lars Fosdal 1792]

IcoFX is my goto tool for Icons.

But, I have to admit I use the last free version: 1.6.4

[Anders Melander 1782]

17 minutes ago, Lars Fosdal said:

IcoFX is my goto tool for Icons.

Does it work well with FMX?

 

I like cats.

[Lars Fosdal 1792]

That depends somewhat on the platform you want your FMX to run on.

The newer IcoFX versions has explicit support for Mac recommended sizes at least.  I haven't checked if it has native icns support, but you can use another tool to convert the format.

Delphi wants .png files in the various sizes for Android and iOS, so that is something that can be exported - but appear to accept both .ico and .icns for MacOS and Linux.

 

[Anders Melander 1782]

18 minutes ago, Lars Fosdal said:

That depends somewhat on the platform you want your FMX to run on.

The newer IcoFX versions has explicit support for Mac recommended sizes at least.  I haven't checked if it has native icns support, but you can use another tool to convert the format.

Delphi wants .png files in the various sizes for Android and iOS, so that is something that can be exported - but appear to accept both .ico and .icns for MacOS and Linux.

Sorry, I should have been more clear in my sarcasm. I probably haven't had enough coffee yet.

What I meant to "say" was that external tools are irrelevant in this context. The OP asked for a Delphi solution for use with FMX.

[Patrick PREMARTIN 69]

22 minutes ago, Lars Fosdal said:

The newer IcoFX versions has explicit support for Mac recommended sizes at least.

IcoFX generate files needed for all platforms. For the sizes we can change if we want more (or less ???) in ICO or ICNS files.

[Lars Fosdal 1792]

The iOS sizes are weird, and needs manual rescaling - so I get the sarcasm from @Anders Melander

There was a thread with another Delphi tool that made icons, but I can't recall which post.

[angusj 126]

On 1/28/2023 at 7:22 AM, David Heffernan said:

I guess the only real complication I can see here is the PNG format for 256px images. 

You can tell by reading the first 4 bytes of the image.

It's $474E5089 when PNG, $00100000 when ICO and $00200000 when CUR.

Unfortunately the TIcon component doesn't do this (at least in Delphi 10.4 upd 2).

The other tricky part is that 256px PNG ico images that aren't transparent frequently use a palette.

This tripped me up recently until I realised, but TPngImage loads paletted PNG images just fine.

 

Edited January 30, 2023 by angusj