BMP ---> ICO

Previous  Top  Next

    
 

 

Автор: Bernhard Angerer

 

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

Code:

procedure TForm1.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;

 

©Drkb::04268

Взято из http://forum.sources.ru

 

 


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

Code:

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.

©Drkb::04267

       

Взято с http://delphiworld.narod.ru