DUzun's Web
Programare, proiecte personale, divertisment

program Bmp2Ico;

​

uses

  Forms,

  Dialogs,

  Graphics,

  SysUtils,

  UGraph in '..\..\_Units\UGraph.pas';

​

{$R *.res}

procedure BmpToIco(FileName: String='');

var a: TPicture;

    b: TBitmap;

    i: TIcon;

    c, t: TRGBPack;

    m, n, l, p, q: Integer;

    precis: word;

    mask: TColor;

begin

  if FileName = '' then begin

     if ParamCount > 0 then begin

       for m := 1 to ParamCount do BmpToIco(ParamStr(m));

       Exit;

     end;

     If not PromptForFileName(FileName, 'Bitmap|*.bmp|All Files|*.*|', '*.bmp', 'Open a Bitmap to convert to Icon', '') then Exit;

  end;

​

 try

  a := TPicture.Create;

  b := TBitmap.Create;

  i := TIcon.Create;

​

  a.LoadFromFile(FileName);

  t := TRGBPack(a.Bitmap.Canvas.Pixels[0,0]); // Transparent color

  m := a.Graphic.Width;

  n := a.Graphic.Height;

  if m < n then l := n else l := m;

  l := ((l-1) shr 4 + 1) shl 4; {16, 32, 64,  128}

​

  {Culoarea de fon pentru b - transparenta}

  b.Canvas.Brush.Color := TColor(t);

  {Dimensiunile - patrat}

  b.Width  := l;

  b.Height := l;

  {Centrul imaginii b}

  m := (l-m)shr 1;

  n := (l-n)shr 1;

​

  precis := 7;                       // Cu aceasta aproximatie, culoarea t se va elimina

  mask := RGB(not 3, not 3, not 3);  // Se elimina unele culori

  for p := a.Graphic.Width-1 downto 0 do for q := a.Graphic.Height-1 downto 0 do begin

    c := TRGBPack(a.Bitmap.Canvas.Pixels[p,q] and mask);

    if (abs(c[0]-t[0])<=precis) and

       (abs(c[1]-t[1])<=precis) and

       (abs(c[2]-t[2])<=precis) then c := t ;

    b.Canvas.Pixels[m + p, n + q] := TColor(c);

  end;

  i := GetIco(b, TColor(t));

  i.SaveToFile(ChangeFileExt(FileName, '.ico'));

 finally

   a.Free;

   b.Free;

   i.Free;

 end;

end;

​

begin

  Application.Initialize;

  BmpToIco;

  Application.Run;

end.

​

​