从 EXE 或 DLL 中获取图标的函数 - 回复 "小李子子" 的问题

问题来源: http://www.cnblogs.com/del/archive/2008/12/25/1070115.html#1413353

---

代码文件:

---

unit Unit1;



interface



uses

  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,

  Dialogs, StdCtrls;



type

  TForm1 = class(TForm)

    Button1: TButton;

    Button2: TButton;

    Button3: TButton;

    procedure Button1Click(Sender: TObject);

    procedure Button2Click(Sender: TObject);

    procedure Button3Click(Sender: TObject);

  end;



var

  Form1: TForm1;



implementation



{$R *.dfm}



uses ShellAPI;



{从 EXE 或 DLL 中获取 ICO 图标的函数, 需要 uses ShellAPI}

function GetIco(const ExePath: string; SavePath: string): Integer; {返回获取总数}

var

  ico: TIcon;

  i,count: Integer;

  FileName: string;

begin

  Result := 0;

  count := ExtractIcon(HInstance, PChar(ExePath), $FFFFFFFF);

  if count = 0 then Exit;



  if not DirectoryExists(SavePath) then ForceDirectories(SavePath);

  FileName := ChangeFileExt(ExtractFileName(ExePath), '');

  SavePath := ExcludeTrailingPathDelimiter(SavePath) + '\' + FileName + '_%.3d.ico';



  ico := TIcon.Create;

  for i := 0 to count - 1 do

  begin

    ico.Handle := ExtractIcon(HInstance, PChar(ExePath), i);

    ico.SaveToFile(Format(SavePath, [i+1]));

  end;

  ico.Free;

  Result := count;

end;



{测试: 获取当前程序图标}

procedure TForm1.Button1Click(Sender: TObject);

begin

  GetIco(ParamStr(0), 'c:\temp');

end;



{测试: 获取记事本图标}

procedure TForm1.Button2Click(Sender: TObject);

var

  buf: array[0..MAX_PATH] of Char;

begin

  GetSystemDirectory(buf, Length(buf)*SizeOf(buf[0]));

  GetIco(buf + '\notepad.exe', 'c:\temp');

end;



{测试: 获取 Windows 的标准图标库}

procedure TForm1.Button3Click(Sender: TObject);

var

  buf: array[0..MAX_PATH] of Char;

begin

  GetSystemDirectory(buf, Length(buf)*SizeOf(buf[0]));

  GetIco(buf + '\Shell32.dll','c:\temp');

end;



end.


 
   

窗体文件:

---

object Form1: TForm1

  Left = 0

  Top = 0

  Caption = 'Form1'

  ClientHeight = 194

  ClientWidth = 206

  Color = clBtnFace

  Font.Charset = DEFAULT_CHARSET

  Font.Color = clWindowText

  Font.Height = -11

  Font.Name = 'Tahoma'

  Font.Style = []

  OldCreateOrder = False

  PixelsPerInch = 96

  TextHeight = 13

  object Button1: TButton

    Left = 64

    Top = 32

    Width = 75

    Height = 25

    Caption = 'Button1'

    TabOrder = 0

    OnClick = Button1Click

  end

  object Button2: TButton

    Left = 64

    Top = 80

    Width = 75

    Height = 25

    Caption = 'Button2'

    TabOrder = 1

    OnClick = Button2Click

  end

  object Button3: TButton

    Left = 64

    Top = 127

    Width = 75

    Height = 25

    Caption = 'Button3'

    TabOrder = 2

    OnClick = Button3Click

  end

end