Programowanie w języku Delphi » Gotowce

Ikonka z bitmapy

  • 2007-04-11 17:51
  • 5 komentarzy
  • 738 odsłon
  • Oceń ten tekst jako pierwszy
To jest kod który konwertuje bitmapę do ikony -
 ikona tylko 16 kolorowa

Objaśnienia :

  • IconBitmap-bitmapka z której robimy ikonkę.

  • InhertedColor - Kolor Odwrócony , kolor Ten na pulpicie jest przeźroczysty a np.w folderze jest kolorem odwróconym (negatywem) podanego jeśli klikniemy w ikonkę staje się on preźroczysty.

  • xHotspot,yHotspot - Ustawienia gorącego punktu ikonki / kursora.
Procedure MakeIcon(const IconBitmap:TBitmap;TransparentColor, InhertedColor:TColor;
var IconOut:Ticon;xHotspot:Cardinal=0;yHotspot:Cardinal=0 );
var
AndMask,XorMask:TBitmap;
 H,V:Byte;
IconInfo : TIconInfo;
TempIsTransparent:boolean;
TempTransparentColor:TColor;
 
 begin
 //--------- do przywrócenia "starych" ustawien bitmapki
 TempIsTransparent:=IconBitmap.Transparent;
TempTransparentColor:=IconBitmap.TransparentColor;
//----------
 
 IconBitmap.TransparentColor :=clWhite;
 IconBitmap.Transparent :=false;
 
 Andmask:=Tbitmap.Create;
 Xormask:=Tbitmap.Create;
 
  IconOut.Width:=IconBitmap.Width;
  IconOut.Height:=IconBitmap.Height;
  IconInfo.fIcon := true;
  IconInfo.xHotspot := xHotspot; {ustawienia gorącego punktu}
  IconInfo.yHotspot := yHotspot;
// Tworzenie Masek
  Andmask.Width:=IconBitmap.Width;
  Andmask.Height:=IconBitmap.Height;
  Andmask.Canvas.Draw(0,0,Iconbitmap);
  XorMask.Width:=IconBitmap.Width;
  XorMask.Height:=IconBitmap.Height;
  XorMask.Monochrome:=true;
 
  for V:=0 to  IconBitmap.Height-1 do
  for H:=0 to IconBitmap.Width-1 do
  begin
  if IconBitmap.Canvas.Pixels[H,V]=TransparentColor then
 
     begin
      AndMask.Canvas.Pixels[H,V]:=$000000;
      XorMask.Canvas.Pixels[H,V]:=$ffffff;
      end else
      if IconBitmap.Canvas.Pixels[H,V]=InhertedColor then
      XorMask.Canvas.Pixels[H,V]:=$ffffff;
 
  end;
 
  //koniec tworzenia masek - tworzenie ikonki
 IconInfo.hbmMask := xorMask.Handle;
 IconInfo.hbmColor := andMask.Handle;
 IconOut.Handle := CreateIconIndirect(IconInfo);
 Andmask.Free;
 Xormask.Free;
//przywracanie "starych ustawień"
IconBitmap.Transparent:=TempIsTransparent;
IconBitmap.TransparentColor:=TempTransparentColor;
 end;


Użycie:
 var
 Ikona:TIcon;
 Bitmap:TBitmap;
 
Ikona:=TIcon.Create; // Tworzymy zmienną
Bitmap:=TBitmap.Create; //tworzymyBitmapkę
Bitmap.Canvas.Brush.Color:= clred;
Bitmap.Width :=32;
Bitmap.Height :=32;
Bitmap.Canvas.Font.Color:=clgreen;
Bitmap.Canvas.TextOut(5,5,'Test');
MakeIcon(Bitmap,clRed,clGreen,Ikona); // tworymy ikonkę 

W przykładzie jako przeźroczysty wybrałem Czerwony a jako odwróny zielony w efekcie uzyskam ikonkę przeźroczystą  z różowym napisem test widocznym w np. folderze (różowym bo to negatyw zielonego) znikającym przy kliknięciu .
Ikonka ta po przeniesieniu na pulpit będzie zupełnie niewidoczna bo kolor czerwony jest przeźroczysty
a napis "Test" zrobiony kolorem Inherted kóry również znika.
Gdybym jako inhertedColor  nie ustawił zielonego napis pozostałby zielony.
Podobnie TransparentColor  mógłbym ustawić na inny i uzyskałbym czerwoną ikonkę z zielonym napisem
Powyższa procedura Zmienne xHotspot,yHotspot ustawia domyślnie na 0 więc nie musiałem pisać
MakeIcon(Bitmap,clRed,clGreen,Ikona,0,0);

 (jak ktoś chce inne wartości to zwyczajnie dopisuje je po przecinku).

5 komentarzy

Piotrekdp 2006-05-19 13:10

znalazłem jeszcze inną metode
<url>http://www.swissdelphicenter.ch/torry/showcode.php?id=426</url>
(ale nie kopiuje bo po co )
ps ta pierwsza metoda "długa" metoda jest lepsza gdy robimy własną maske
wtedy można zrobić dowolne warianty ikonki :)

Pino_87 2005-11-14 12:22

Ładnie wygląda ale nie wiem jak zadziała w praktyce. No ale w końcu znalazłem taki bajer bo od dawna czegoś takiego szukałem

migajek 2005-08-19 20:27

nie testowalem - ale wyglada ladnie :)
// tylko IMO to bardziej FAQ/Gotowiec nie art

CooBek 2005-08-19 21:43

o, super! :) Tylko, ze tutaj \" FICO.SaveToFile(\'ikona.ico\')\" zapomniales srednika na koncu linii ;) Poza tym mozna zamiast tego \'ikona.ico\' wrzucic zmienna (dodac parametr do procedury np.) :)

Artur 2005-08-20 11:39

Jest jeszcze inny sposób - znalazłem na torry.net

procedure bmp2ico(Image: TImage; FileName: TFilename);
var
  Bmp: TBitmap;
  Icon: TIcon;
  ImageList: TImageList;
begin
  Bmp  := TBitmap.Create;
  Icon := TIcon.Create;
  try
    Bmp.Assign(Image.Picture);
    ImageList := TImageList.CreateSize(Bmp.Width, Bmp.Height);
    try
      ImageList.AddMasked(Bmp, Bmp.TransparentColor);
      ImageList.GetIcon(0, Icon);
      // zapisywanie do pliku
      Icon.SaveToFile(FileName);
    finally
      ImageList.Free;
    end;
  finally
    Bmp.Free;
    Icon.Free;
  end;
end;
 
 
procedure TForm1.Button1Click(Sender: TObject);
begin
    bmp2ico(Image1, \'test.ico\');
end;