精华区 [关闭][返回]

当前位置:网易精华区>>讨论区精华>>编程开发>>● Delphi>>图形界面和窗体>>把位图变成一个图标实现Acdsee式的预览

主题:把位图变成一个图标实现Acdsee式的预览
发信人: aaa234(我只只在乎你)
整理人: teleme(2001-06-04 15:44:32), 站内信件
procedure TForm1.Button1Click(Sender: TObject); 
var 
  IconSizeX : integer; 
  IconSizeY : integer; 
  AndMask : TBitmap; 
  XOrMask : TBitmap; 
  IconInfo : TIconInfo; 
  Icon : TIcon; 
begin 
{Get the icon size} 
  IconSizeX := GetSystemMetrics(SM_CXICON); 
  IconSizeY := GetSystemMetrics(SM_CYICON); 

{Create the "And" mask} 
  AndMask := TBitmap.Create; 
  AndMask.Monochrome := true; 
  AndMask.Width := IconSizeX; 
  AndMask.Height := IconSizeY; 

{Draw on the "And" mask} 
  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); 

{Draw as a test} 
  Form1.Canvas.Draw(IconSizeX * 2, IconSizeY, AndMask); 

{Create the "XOr" mask} 
  XOrMask := TBitmap.Create; 
  XOrMask.Width := IconSizeX; 
  XOrMask.Height := IconSizeY; 

{Draw on the "XOr" mask} 
  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); 

{Draw as a test} 
  Form1.Canvas.Draw(IconSizeX * 4, IconSizeY, XOrMask); 

{Create a icon} 
  Icon := TIcon.Create; 
  IconInfo.fIcon := true; 
  IconInfo.xHotspot := 0; 
  IconInfo.yHotspot := 0; 
  IconInfo.hbmMask := AndMask.Handle; 
  IconInfo.hbmColor := XOrMask.Handle; 
  Icon.Handle := CreateIconIndirect(IconInfo); 

{Destroy the temporary bitmaps} 
  AndMask.Free; 
  XOrMask.Free; 

{Draw as a test} 
  Form1.Canvas.Draw(IconSizeX * 6, IconSizeY, Icon); 

{Assign the application icon} 
  Application.Icon := Icon; 

{Force a repaint} 
  InvalidateRect(Application.Handle, nil, true); 

{Free the icon} 
  Icon.Free; 
end;   
  

[关闭][返回]