Главная страница
    Top.Mail.Ru    Яндекс.Метрика
Текущий архив: 2006.04.02;
Скачать: CL | DM;

Вниз

Как на Winapi программно нарисовать иконку и получить ее в виде hicon   Найти похожие ветки 

 
Alexx2000   (2006-01-13 01:34) [0]

А если точнее необходимо 2 символа перевести в иконку.


 
Rouse_ ©   (2006-01-13 10:18) [1]

Отрисовать что нужно на HBITMAP и сделать CreateIconIndirect


 
Alexx2000   (2006-01-13 20:22) [2]

Как раз это у меня не получаеться, уже замучался. Пожалуйста, если можешь приведи пример кода.


 
Fay ©   (2006-01-13 20:30) [3]

2 Alexx2000   (13.01.06 20:22) [2]
Напиши, как не получается


 
Alexx2000   (2006-01-14 18:31) [4]

Скажу сразу я не специалист по программированию на WinApi, вот нашел на каком - то форуме пример и немного изменил под себя. Одноко он выводит иконку залитую белым цветом.

function DrawIcon(width, height: integer): HICON;
var
ii: ICONINFO;
hScreenDC,
hIconDC,
hMaskDC: HDC;
hOldIconDC,
hOldMaskDC: HGDIOBJ;
r: TRECT;
hIconX: HICON;
begin

ii.fIcon:= TRUE;
hScreenDC:= GetDC(0);
hIconDC:= CreateCompatibleDC(hScreenDC);
hMaskDC:= CreateCompatibleDC(hScreenDC);

ii.xHotspot:= 0;
ii.yHotspot:= 0;
ii.hbmColor:= CreateCompatibleBitmap(hScreenDC,width,height);
ii.hbmMask:= CreateCompatibleBitmap(hMaskDC,width,height);

ReleaseDC(0,hScreenDC);

hOldIconDC:= SelectObject(hIconDC,ii.hbmColor);
hOldMaskDC:= SelectObject(hMaskDC,ii.hbmMask);

BitBlt(hIconDC,0,0,width,height,0,0,0,WHITENESS);
BitBlt(hMaskDC,0,0,width,height,0,0,0,BLACKNESS);

//НАЧАЛО РИСОВАНИЯ

r.Left:= 1;
r.Right:= 1;
r.Top:= 1;
r.Bottom:= 1;
SetTextColor(hIconDC,$0000FF00);
DrawText(hIconDC,"R1",2,r,0);

//КОНЕЦ РИСОВАНИЯ

SelectObject(hIconDC,hOldIconDC);
SelectObject(hMaskDC,hOldMaskDC);

hIconX:= CreateIconIndirect(ii);

//Cleanup
DeleteObject(ii.hbmColor);
DeleteObject(ii.hbmMask);
DeleteDC(hMaskDC);
DeleteDC(hIconDC);

Result:= hIconX;
end;


 
Eraser ©   (2006-01-14 19:36) [5]


> Alexx2000   (14.01.06 18:31) [4]

читай [1].


 
Alexx2000   (2006-01-15 18:01) [6]

Иконку создать получилось. Но почему она черно - белая?


 
Zeqfreed ©   (2006-01-15 18:05) [7]

Alexx2000   (15.01.06 18:01) [6]
Замени единичку на нулик в семнадцатой строке.


 
Eraser ©   (2006-01-15 18:45) [8]


> Alexx2000   (15.01.06 18:01) [6]
>
> Иконку создать получилось. Но почему она черно - белая?

Прорисовывать на битмапе надо!


 
Rouse_ ©   (2006-01-15 18:54) [9]

Мдя... заставил таки ты меня сесть в выходные за Дельфю :) Лови...

unit Unit1;

interface

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

type
 TForm1 = class(TForm)
   procedure FormCreate(Sender: TObject);
 end;

var
 Form1: TForm1;

implementation

{$R *.dfm}

type
 TDoubleChar = String[2];

 function CreateIconFromChar(const Value: TDoubleChar): HICON;
var
 DC: HDC;
 IcoInfo : TIconInfo;
 Bitmap, BitMask: HBitmap;
 Brush: HBrush;
 BitCount: Integer;
 BitmapRect: TRect;
begin
 Result := 0;
 DC := CreateCompatibleDC(0);
 if DC = 0 then RaiseLastOSError;
 try
   BitCount := GetDeviceCaps(DC, BITSPIXEL);
   Bitmap := CreateBitmap(16, 16, 2, BitCount div 2, nil);
   if Bitmap = 0 then RaiseLastOSError;
   try
     BitMask := CreateBitmap(16, 16, 1, 1, nil);
     if BitMask = 0 then RaiseLastOSError;
     try
       SelectObject(DC, Bitmap);
       Brush := CreateSolidBrush($FFFFFF);
       if Brush = 0 then RaiseLastOSError;
       try
         with BitmapRect do
         begin
           Left := 0;
           Right := 16;
           Top := 0;
           Bottom := 16;
         end;
         FillRect(DC, BitmapRect, Brush);
       finally
         DeleteObject(Brush);
       end;
       TextOut(DC, 0, 0, PChar(String(Value)), Length(Value));
       ZeroMemory(@IcoInfo, SizeOf(TIconInfo));
       IcoInfo.hbmMask := BitMask;
       IcoInfo.hbmColor := Bitmap;
       Result := CreateIconIndirect(IcoInfo);
     finally
       DeleteObject(BitMask);
     end;
   finally
     DeleteObject(Bitmap);
   end;
 finally
   DeleteDC(DC);
 end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
 Icon.Handle := CreateIconFromChar("AB");
end;

end.


 
Alexx2000   (2006-01-15 19:54) [10]

Все заработало. Всем спасибо, особо благодарен Rouse_
за его пример (Надеюсь тебя это не сильно затруднило).


 
Rouse_ ©   (2006-01-15 20:44) [11]


> Надеюсь тебя это не сильно затруднило

Да все пучком, пришлось просто за пивом сбегать :) Шутка :)


 
ss2   (2006-01-16 22:09) [12]

procedure TForm1.Timer1Timer(Sender: TObject);
var
bi:TBitmap;
ic:TIcon;
iml:TImageList;
s:String;
begin

Caption:=FormatDateTime("c",Now);
s:=Caption[18]+Caption[19];

bi:=TBitmap.Create;
ic:=TIcon.Create;
bi.Height:=16;
bi.Width:=16;
bi.Canvas.Brush.Color:=clFuchsia;
bi.Canvas.FillRect(Rect(0,0,16,16));
bi.Canvas.Font.Style:=[fsBold];
bi.Canvas.Font.Name:="MS Sans Serif";
bi.Canvas.Font.Color:=clWhite;
bi.Canvas.TextOut(-1,2,s);
iml:=TImageList.Create(Self);
iml.AddMasked(bi,clFuchsia);
iml.GetIcon(0,ic);

Icon.Handle :=Ic.Handle;

bi.Free;
iml.Free;
ic.Free;
end;
Попробуй вот это.



Страницы: 1 вся ветка

Текущий архив: 2006.04.02;
Скачать: CL | DM;

Наверх




Память: 0.48 MB
Время: 0.056 c
4-1136969518
menart
2006-01-11 11:51
2006.04.02
оброботка сообщение при записи диска


8-1130308609
Romanina
2005-10-26 10:36
2006.04.02
Проигрывание wav с помощью DirectSound


15-1141913753
Dok_3D
2006-03-09 17:15
2006.04.02
Фильтры для водопроводной воды


3-1139291911
VitV
2006-02-07 08:58
2006.04.02
Delphi+access. Проблема загрузки рисунка.


15-1141848603
Nic
2006-03-08 23:10
2006.04.02
Машина студента developer a





Afrikaans Albanian Arabic Armenian Azerbaijani Basque Belarusian Bulgarian Catalan Chinese (Simplified) Chinese (Traditional) Croatian Czech Danish Dutch English Estonian Filipino Finnish French
Galician Georgian German Greek Haitian Creole Hebrew Hindi Hungarian Icelandic Indonesian Irish Italian Japanese Korean Latvian Lithuanian Macedonian Malay Maltese Norwegian
Persian Polish Portuguese Romanian Russian Serbian Slovak Slovenian Spanish Swahili Swedish Thai Turkish Ukrainian Urdu Vietnamese Welsh Yiddish Bengali Bosnian
Cebuano Esperanto Gujarati Hausa Hmong Igbo Javanese Kannada Khmer Lao Latin Maori Marathi Mongolian Nepali Punjabi Somali Tamil Telugu Yoruba
Zulu
Английский Французский Немецкий Итальянский Португальский Русский Испанский