从 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

posted on 2008-12-26 11:52  万一  阅读(2827)  评论(10)  编辑  收藏