BMP ---> ICO

Автор: Bernhard Angerer

Вам необходимо создать два битмапа, битмап маски (назовём его "AND" bitmap) и битмап изображения (назовём его XOR bitmap). Вы можете пропустить обработчики для "AND" и "XOR" битмапов в Windows API функции CreateIconIndirect() и использовать обработчик возвращённой иконки в Вашем приложении.

procedureTForm1.Button1Click(Sender: TObject); 
var 
  IconSizeX : integer; 
  IconSizeY : integer; 


  AndMask : TBitmap; 
  XOrMask : TBitmap; 
  IconInfo : TIconInfo; 
  Icon : TIcon; 
begin 
{Получаем размер иконки} 
  IconSizeX := GetSystemMetrics(SM_CXICON); 
  IconSizeY := GetSystemMetrics(SM_CYICON); 

{Создаём маску "And"} 
  AndMask := TBitmap.Create; 
  AndMask.Monochrome := true; 
  AndMask.Width := IconSizeX; 
  AndMask.Height := IconSizeY; 

{Рисуем на маске "And"} 
  AndMask.Canvas.Brush.Color := clWhite; 
  AndMask.Canvas.FillRect(Rect(0, 0, IconSizeX, IconSizeY)); 
  AndMask.Canvas.Brush.Color := clBlack; 
  AndMask.Canvas.Ellipse(4, 4, IconSizeX - 4, IconSizeY - 4); 

{Рисуем для теста} 
  Form1.Canvas.Draw(IconSizeX * 2, IconSizeY, AndMask); 

{Создаём маску "XOr"} 
  XOrMask := TBitmap.Create; 
  XOrMask.Width := IconSizeX; 
  XOrMask.Height := IconSizeY; 

{Рисуем на маске "XOr"} 
  XOrMask.Canvas.Brush.Color := ClBlack; 
  XOrMask.Canvas.FillRect(Rect(0, 0, IconSizeX, IconSizeY)); 
  XOrMask.Canvas.Pen.Color := clRed; 
  XOrMask.Canvas.Brush.Color := clRed; 
  XOrMask.Canvas.Ellipse(4, 4, IconSizeX - 4, IconSizeY - 4); 

{Рисуем в качестве теста} 
  Form1.Canvas.Draw(IconSizeX * 4, IconSizeY, XOrMask); 

{Создаём иконку} 
  Icon := TIcon.Create; 
  IconInfo.fIcon := true; 
  IconInfo.xHotspot := 0; 
  IconInfo.yHotspot := 0; 
  IconInfo.hbmMask := AndMask.Handle; 
  IconInfo.hbmColor := XOrMask.Handle; 
  Icon.Handle := CreateIconIndirect(IconInfo); 

{Уничтожаем временные битмапы} 
  AndMask.Free; 
  XOrMask.Free; 

{Рисуем в качестве теста} 
  Form1.Canvas.Draw(IconSizeX * 6, IconSizeY, Icon); 

{Объявляем иконку в качестве иконки приложения} 
  Application.Icon := Icon; 

{генерируем перерисовку} 
  InvalidateRect(Application.Handle, nil, true); 

{Освобождаем иконку} 
  Icon.Free; 
end; 

Взято с Исходников.ru


Способ преобразования изображения размером 32x32 в иконку.



unit main;

interface

uses

  Windows, Messages, SysUtils, Classes, Graphics, Controls,
  Forms, Dialogs, ExtCtrls, StdCtrls;

type

  TForm1 = class(TForm)
    Button1: TButton;
    Image1: TImage;
    Image2: TImage;
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var

  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
var
  winDC, srcdc, destdc: HDC;

  oldBitmap: HBitmap;
  iinfo: TICONINFO;
begin

  GetIconInfo(Image1.Picture.Icon.Handle, iinfo);

  WinDC := getDC(handle);
  srcDC := CreateCompatibleDC(WinDC);
  destDC := CreateCompatibleDC(WinDC);
  oldBitmap := SelectObject(destDC, iinfo.hbmColor);
  oldBitmap := SelectObject(srcDC, iinfo.hbmMask);

  BitBlt(destdc, 0, 0, Image1.picture.icon.width,
    Image1.picture.icon.height,
    srcdc, 0, 0, SRCPAINT);
  Image2.picture.bitmap.handle := SelectObject(destDC, oldBitmap);
  DeleteDC(destDC);
  DeleteDC(srcDC);
  DeleteDC(WinDC);

  image2.Picture.Bitmap.savetofile(ExtractFilePath(Application.ExeName)
    + 'myfile.bmp');
end;

procedure TForm1.FormCreate(Sender: TObject);
begin

  image1.picture.icon.loadfromfile('c:\myicon.ico');
end;

end.