获取应用程序图标的代码

获取应用程序图标的代码 

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Button1: TButton;
    Image1: TImage;
    Button2: TButton;
    Edit1: TEdit;
    OpenDialog1: TOpenDialog;
    Button3: TButton;
    SaveDialog1: TSaveDialog;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
    procedure geticon;
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);


begin
  getIcon; 
end;

procedure TForm1.geticon;
var 
  Count : Integer; 
  FileName : String; 
  i:integer; 
begin 
  if( FileName <> Edit1.Text ) then 
  begin 
    FileName:=Edit1.Text; 
    I := 0; 
    Count := ExtractIcon( Application.Handle, PChar(FileName),
    $FFFFFFFF ); 
  end 
  else 
    Inc(I); 
  if( I < Count ) then 
    Image1.Picture.Icon.Handle := 
    ExtractIcon( Application.Handle, PChar(FileName), I ) 
  else
    ShowMessage('没有找到！' );
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  opendialog1.Execute;
edit1.Text:=opendialog1.FileName;
end;


procedure TForm1.Button3Click(Sender: TObject);
begin
  savedialog1.Execute;
 image1.Picture.SaveToFile(savedialog1.FileName);
end;

end.

delphi TIcon保存ico文件时失真的解决办法

提取exe文件中的图标并保存为ico文件：
ico := TIcon.Create;
try
  ico.handle := ExtractIcon(hInstance, ExeFileName, 0);
  ico.SaveToFile(''c:\001.ico'');
finally
  ico.free;
end;
保 存后的001.ico文件严重失真，我们打开Graphics.pas文件，找到writeIcon函数，在这个函数里有这样一行代码：
InternalGetDIBSizes(IconInfo.hbmColor, ColorInfoSize, ColorBitsSize, 16);
InternalGetDIBSizes函数的原型是这样声明的：
procedure InternalGetDIBSizes(Bitmap: HBITMAP; var InfoHeaderSize: DWORD; var ImageSize: DWORD; Colors: Integer);
我们可以看出最后一个参数指要保存的图标的颜色数，在 writeIcon函数中指定为16，也就是说保存为16位色，现在的图标都是32位真彩色，难怪会失真了。
我们把那行代码改成：
InternalGetDIBSizes(IconInfo.hbmColor, ColorInfoSize, ColorBitsSize, 65536);
当然还有下面一行
InternalGetDIB(IconInfo.hbmColor, 0, ColorInfo^, ColorBits^, 16);
也要改成
InternalGetDIB(IconInfo.hbmColor, 0, ColorInfo^, ColorBits^, 65536);
我们将改过后的Graphics.pas文件保存到当前工程目录下面， 然后重新编译程序，再次运行，图标就不会失真了