procedure TForm1.Button1Click(Sender: TObject);
var
  LSizeX : Integer;
  LSizeY : Integer;
  LText  : string;
begin
  LSizeX := GetSystemMetrics(SM_CXICON);
  LSizeY := GetSystemMetrics(SM_CYICON);

  LText := IntToStr(LSizeX) + sLineBreak + IntToStr(LSizeY);
  MessageBox(Handle, PChar(LText), '情報', MB_ICONINFORMATION);
end;

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Button1: TButton;
    Image1: TImage;
    Button2: TButton;
    SavePictureDialog1: TSavePictureDialog;
    Label1: TLabel;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    { Private 宣言 }
    FFileName : string;
    FIconIndex : Integer;
  public
    { Public 宣言 }
  end;

  //---------------------------------------------------------------------------
  //  shell32.dllの序数62の名前なし関数を使用するための関数の定義
  //  この関数は非公開API関数
  //
  //  usesにShellAPIが必要．
  //---------------------------------------------------------------------------
  function SH_PickIconDlg(
      Handle       : THandle;
      lpFileName   : PChar;
      var FileSize : DWORD;
      var Index    : Integer):Integer; stdcall; external 'shell32.dll' index 62;

var
  Form1: TForm1;

implementation

{$R *.DFM}

//=============================================================================
//  フォーム生成時の処理
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
begin
  FFileName := 'imageres.dll';
end;

//=============================================================================
//  [アイコンの変更]ダイアログを表示
//  選択したら，そのアイコンをImage1に表示
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  LpFileName : PChar;
  LFileSize  : DWORD;
  LIcon      : TIcon;
begin
  LFileSize  := MAX_PATH;
  LpFileName := StrAlloc(LFileSize + 1);
  StrPCopy(LpFileName, FFileName);

  LIcon := TIcon.Create;
  try
    //関数を実行
    if SH_PickIconDlg(Handle, LpFileName, LFileSize, FIconIndex) = 1 then begin
      //アイコンを取出す
      LIcon.Handle := ExtractIcon(hInstance, LpFileName, FIconIndex);
      Image1.Picture.Assign(LIcon);
      Label1.Caption := 'IconIndex : ' + IntToStr(FIconIndex);

      FFileName := LpFileName;
    end;
  finally
    FreeAndNil(LIcon);
    StrDispose(LpFileName);
  end;
end;

//=============================================================================
//  取り出したアイコンを保存する
//=============================================================================
procedure TForm1.Button2Click(Sender: TObject);
var
  LIcon     : TIcon;
  LFileName : string;
begin
  if Image1.Picture = nil then exit;

  SavePictureDialog1.InitialDir := ExtractFileDir(Application.ExeName);
  if SavePictureDialog1.Execute then begin
    LIcon := TIcon.Create;
    try
      LIcon.Assign(Image1.Picture.Icon);
      LFileName := SavePictureDialog1.FileName;
      if ExtractFileExt(LFileName) = '' then begin
        LFileName := LFileName + '.ico';
      end;
      LIcon.SaveToFile(LFileName);
    finally
      FreeAndNil(LIcon);
    end;
  end;
end;

end.

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Button1: TButton;
    Image1: TImage;
    Button2: TButton;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    { Private 宣言 }
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses
  ShellAPI;

{$R *.dfm}

//=============================================================================
//  アイコンの番号を指定してシステムのアイコン画像を取得する
//  usesにShellAPIが必要
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  LDllName   : string;
  LIconIndex : UINT;
  LIcon      : TIcon;
  LExeDir    : string;
begin
  LDllName := 'imageres.dll';
  LExeDir  := ExtractFilePath(Application.ExeName);

  LIcon := TIcon.Create;
  try
    LIconIndex   := 94;
    LIcon.Handle := ExtractIcon(hInstance, PChar(LDllName), LIconIndex);
    if LIcon.Handle > 0 then begin
      Image1.Canvas.Draw(0, 0, LIcon);
      LIcon.SaveToFile(LExeDir + LDllName + '_' + IntToStr(LIconIndex) + '.ico');
    end;

    LIconIndex   := 73;
    LIcon.Handle := ExtractIcon(hInstance, PChar(LDllName), LIconIndex);
    if LIcon.Handle > 0 then begin
      Image1.Canvas.Draw(50, 0, LIcon);
      LIcon.SaveToFile(LExeDir + LDllName + '_' + IntToStr(LIconIndex) + '.ico');
    end;

    LIconIndex   := 79;
    LIcon.Handle := ExtractIcon(hInstance, PChar(LDllName), LIconIndex);
    if LIcon.Handle > 0 then begin
      Image1.Canvas.Draw(100, 0, LIcon);
      LIcon.SaveToFile(LExeDir + LDllName + '_' + IntToStr(LIconIndex) + '.ico');
    end;

    LIconIndex   := 76;
    LIcon.Handle := ExtractIcon(hInstance, PChar(LDllName), LIconIndex);
    if LIcon.Handle > 0 then begin
      Image1.Canvas.Draw(150, 0, LIcon);
      LIcon.SaveToFile(LExeDir + LDllName + '_' + IntToStr(LIconIndex) + '.ico');
    end;

    LIconIndex   := 93;
    LIcon.Handle := ExtractIcon(hInstance, PChar(LDllName), LIconIndex);
    if LIcon.Handle > 0 then begin
      Image1.Canvas.Draw(200, 0, LIcon);
      LIcon.SaveToFile(LExeDir + LDllName + '_' + IntToStr(LIconIndex) + '.ico');
    end;
  finally
    FreeAndNil(LIcon);
  end;
end;

//=============================================================================
//  フォーム生成時の処理
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
begin
  Edit1.Text := 'imageres.dll';
end;

//=============================================================================
//  指定ファイル内のすべてのアイコンを取得する
//  保存のみ(上書き保存)
//  usesにShellAPIが必要
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  LDllName   : string;
  LIconIndex : UINT;
  LIcon      : TIcon;
  LExeDir    : string;
  LCount     : Integer;
begin
  LDllName := Trim(Edit1.Text);
  LExeDir  := ExtractFilePath(Application.ExeName) + 'ICONS' + PathDelim;
  ForceDirectories(LExeDir);

  //アイコンの総数を取得
  LCount := -1;
  LCount :=　ExtractIcon(hInstance, PChar(LDllName), LCount);

  LIcon := TIcon.Create;
  try
    for LIconIndex := 0 to LCount - 1 do begin
      LIcon.Handle := ExtractIcon(hInstance, PChar(LDllName), LIconIndex);
      if LIcon.Handle > 0 then begin
        LIcon.SaveToFile(LExeDir + LDllName + '_' + IntToStr(LIconIndex) + '.ico');
      end;
      Application.ProcessMessages;
    end;
  finally
    FreeAndNil(LIcon);
  end;
end;

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Button1: TButton;
    Image1: TImage;
    Image2: TImage;
    procedure Button1Click(Sender: TObject);
  private
    { Private 宣言 }
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses
  ShellAPI;

{$R *.dfm}

//=============================================================================
//  ExtractIconEx関数を使用して大きいアイコンと小さいアイコンを取り出す
//  usesにShellAPIが必要
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  LSrcFileName  : string;
  LIconIndex    : UINT;
  LhIconLarge   : HICON;
  LhIconSmall   : HICON;
  LIcon         : TIcon;
  LSaveFileName : string;
begin
  LSrcFileName  := 'imageres.dll';
  LIconIndex    := 94;
  LSaveFileName := ExtractFilePath(Application.ExeName) + LSrcFileName
                 + '_' + IntToStr(LIconIndex);

  //アイコンを取り出す
  ExtractIconEx(PChar(LSrcFileName), LIconIndex,  LhIconLarge, LhIconSmall, 1);

  if LhIconLarge > 0 then begin
    LIcon := TIcon.Create;
    try
      LIcon.Handle := LhIconLarge;

      Image1.Canvas.Draw(0, 0, LIcon);
      LIcon.SaveToFile(LSaveFileName + '_Large.ico');
    finally
      FreeAndNil(LIcon);
    end;
  end;

  if LhIconSmall > 0 then begin
    LIcon := TIcon.Create;
    try
      LIcon.Handle := LhIconSmall;

      Image2.Canvas.Draw(0, 0, LIcon);
      LIcon.SaveToFile(LSaveFileName + '_Small.ico');
    finally
      FreeAndNil(LIcon);
    end;
  end;
end;

end.

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Button1: TButton;
    Image1: TImage;
    RadioGroup1: TRadioGroup;
    Edit1: TEdit;
    Label1: TLabel;
    SpeedButton1: TSpeedButton;
    OpenDialog1: TOpenDialog;
    SpinEdit1: TSpinEdit;
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure SpeedButton1Click(Sender: TObject);
  private
    { Private 宣言 }
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

function PrivateExtractIcon(lpszFile   : PChar;
                            nIconIndex : Integer;
                            cxIcon     : Integer;
                            cyIcon     : Integer;
                            phicon     : PHandle;
                            piconid    : PUINT;
                            nIcons     : UINT;
                            flags      : UINT): UINT; stdcall;
                            external 'user32.dll' name 'PrivateExtractIconsW';


//=============================================================================
//  フォーム生成時の処理
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
begin
  OpenDialog1.InitialDir := ExpandFileName('..\');
  RadioGroup1.ItemIndex := 2;
  Edit1.Text := '';
end;

//=============================================================================
//  PrivateExtractIcon関数を使用してアイコンを任意のサイズで取得する
//  全てのサイズのアイコンが格納されているわけではない
//  格納されていないサイズを指定すると拡大または縮小した画像となる
//
//  PrivateExtractIcon関数でアイコンが取得できのは以下のファイル
//    .EXE, .DLL, .ICO, .CUR, .BMP, .ANI
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  LSrcFileName : string;
  LIconIndex   : UINT;
  LIconSize    : Integer;
  LhIcon       : HICON;
  LnIcons      : UINT;
  LnIconId     : UINT;
  LIcon        : TIcon;
begin
  Image1.Picture.Assign(nil);

  LSrcFileName := Trim(Edit1.Text);
  LIconIndex   := SpinEdit1.Value;
  LIconSize    := 32;
  LnIcons      := 1;

  if RadioGroup1.ItemIndex = 0 then  LIconSize := 16;
  if RadioGroup1.ItemIndex = 1 then  LIconSize := 24;
  if RadioGroup1.ItemIndex = 2 then  LIconSize := 32;
  if RadioGroup1.ItemIndex = 3 then  LIconSize := 48;
  if RadioGroup1.ItemIndex = 4 then  LIconSize := 64;
  if RadioGroup1.ItemIndex = 5 then  LIconSize := 128;
  if RadioGroup1.ItemIndex = 6 then  LIconSize := 256;

  //アイコンを取り出す
  //関数の戻り値は取得したアイコンの数
  if PrivateExtractIcon(PChar(LSrcFileName),
                        LIconIndex,
                        LIconSize,
                        LIconSize,
                        @LhIcon,
                        @LnIconId,
                        LnIcons,
                        LR_LOADFROMFILE) = LnIcons then begin
    LIcon := TIcon.Create;
    try
      Label1.Caption := 'IconID : ' + IntToStr(LnIconId);

      if LhIcon <> 0 then begin
        LIcon.Handle   := LhIcon;
        Image1.Canvas.Draw(0, 0, LIcon);
        //描画したアイコンを保存
        //だだし全て同じ名前で上書き保存
        LIcon.SaveToFile(IntToStr(LIconSize) + '.ico');
        Application.ProcessMessages;
      end;
    finally
      FreeAndNil(LIcon);
    end;
  end;
end;

//=============================================================================
//  ダイアログを表示してファイルを選択
//=============================================================================
procedure TForm1.SpeedButton1Click(Sender: TObject);
begin
  OpenDialog1.OptionsEx := [];
  OpenDialog1.FileName  := '';
  if not OpenDialog1.Execute then exit;

  OpenDialog1.InitialDir := ExtractFileDir(OpenDialog1.FileName);
  Edit1.Text := OpenDialog1.FileName;
  SpinEdit1.Value := 0;
  Button1Click(nil);
end;

end.

procedure TForm1.Button1Click(Sender: TObject);
var
  LSrcFileName : string;
  LnIcons      : UINT;
begin
  LSrcFileName := 'c:\windows\System32\Shell32.dll';

  // DLL または EXE 内のアイコン数を取得
  // DLL, EXE 以外では不可
  LnIcons := PrivateExtractIcon(PChar(LSrcFileName),
                                0,
                                0,
                                0,
                                nil,
                                nil,
                                0,
                                LR_LOADFROMFILE);
  MessageBox(Handle, PChar(IntToStr(LnIcons)), 'アイコン数', MB_ICONINFORMATION);
end;

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Button1: TButton;
    Image1: TImage;
    procedure Button1Click(Sender: TObject);
  private
    { Private 宣言 }
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses
  ShellAPI;

{$R *.dfm}

//-----------------------------------------------------------------------------
//  システム関係のアイコンを取得する関数
//  SHGetStockIconInfoはWindows Vista以降で使用可能
//  これらのアイコンは"C:\Windows\system32\imageres.dll"に格納されている
//
//  usesにShellAPIが必要
//-----------------------------------------------------------------------------
function GetStockIcon(Id: Integer; ASize: Cardinal; AIcon: TIcon): HRESULT;
var
  LSHIconInfo : TSHStockIconInfo;
  LuFlags     : Cardinal;
  LResCode    : HResult;
begin
  Result := 0;
  LSHIconInfo.cbSize := SizeOf(LSHIconInfo);

  LuFlags  := SHGSI_ICON or ASize;
  LResCode := SHGetStockIconInfo(id, LuFlags, LSHIconInfo);

  Result := LResCode;
  if Result = S_OK then AIcon.Handle := LSHIconInfo.hIcon;
end;

//=============================================================================
//  システムのアイコン画像を取得する
//  必要であればビットマップ画像等に変換して使用する
//  SHGSI_LARGEICONは大きいアイコン
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  LIcon     : TIcon;
  LFileName : string;
begin
  LFileName := ExtractFilePath(Application.ExeName);
  LIcon := TIcon.Create;
  try
    if GetStockIcon(SIID_HELP, SHGSI_LARGEICON, LIcon) = S_OK then begin
      Image1.Canvas.Draw(0, 0, LIcon);
      LIcon.SaveToFile(LFileName + 'SIID_HELP.ico');
    end;

    if GetStockIcon(SIID_SHIELD, SHGSI_LARGEICON, LIcon) = S_OK then begin
      Image1.Canvas.Draw(50, 0, LIcon);
      LIcon.SaveToFile(LFileName + 'SIID_SHIELD.ico');
    end;

    if GetStockIcon(SIID_WARNING, SHGSI_LARGEICON, LIcon) = S_OK then begin
      Image1.Canvas.Draw(100, 0, LIcon);
      LIcon.SaveToFile(LFileName + 'SIID_WARNING.ico');
    end;

    if GetStockIcon(SIID_INFO, SHGSI_LARGEICON, LIcon) = S_OK then begin
      Image1.Canvas.Draw(150, 0, LIcon);
      LIcon.SaveToFile(LFileName + 'SIID_INFO.ico');
    end;

    if GetStockIcon(SIID_ERROR, SHGSI_LARGEICON, LIcon) = S_OK then begin
      Image1.Canvas.Draw(200, 0, LIcon);
      LIcon.SaveToFile(LFileName + 'SIID_ERROR.ico');
    end;
  finally
    FreeAndNil(LIcon);
  end;
end;

end.

//=============================================================================
//  LoadIcon関数でシステムリソースのアイコンを取得
//  LoadIcon関数の第1引数を0にして，第2引数にID値を指定する
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  LhIcon : HICON;
  LIcon  : TIcon;
begin
  LIcon := TIcon.Create;
  try
    LIcon.Handle := LoadIcon(0, IDI_QUESTION);
    Image1.Canvas.Draw(0, 0, LIcon);

    LIcon.Handle := LoadIcon(0, IDI_SHIELD);
    Image1.Canvas.Draw(50, 0, LIcon);

    LIcon.Handle := LoadIcon(0, IDI_WARNING);
    Image1.Canvas.Draw(100, 0, LIcon);

    LIcon.Handle := LoadIcon(0, IDI_INFORMATION);
    Image1.Canvas.Draw(150, 0, LIcon);

    LIcon.Handle := LoadIcon(0, IDI_HAND);
    Image1.Canvas.Draw(200, 0, LIcon);
  finally
    FreeAndNil(LIcon);
  end;
end;

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    OpenDialog1: TOpenDialog;
    Image1: TImage;
    Edit1: TEdit;
    SpeedButton1: TSpeedButton;
    Button1: TButton;
    CheckBox1: TCheckBox;
    CheckBox2: TCheckBox;
    CheckBox3: TCheckBox;
    CheckBox4: TCheckBox;
    CheckBox5: TCheckBox;
    CheckBox6: TCheckBox;
    CheckBox7: TCheckBox;
    CheckBox8: TCheckBox;
    procedure FormCreate(Sender: TObject);
    procedure SpeedButton1Click(Sender: TObject);
    procedure Button1Click(Sender: TObject);
  private
    { Private 宣言 }
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses
  ShellApi;

{$R *.dfm}

//=============================================================================
//  フォーム生成時の処理
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
begin
  OpenDialog1.InitialDir := ExpandFileName('..\');

  Edit1.Text        := ExtractFilePath(Application.ExeName) + 'Project1.exe';
  Edit1.AutoSelect  := False;
  CheckBox1.Checked := True;
end;

//=============================================================================
//  ダイアログを表示してファイルを選択
//=============================================================================
procedure TForm1.SpeedButton1Click(Sender: TObject);
begin
  //.lnkファイルの場合,リンク先でなく.lnkファイルそのものを取得するようにする
  //TOpenDialogは.lnkの場合，デフォルトではリンク先のファイル名を取得する
  OpenDialog1.Options    := OpenDialog1.Options + [ofNoDereferenceLinks];
  OpenDialog1.OptionsEx  := [];
  OpenDialog1.FileName   := '';
  if not OpenDialog1.Execute then exit;

  OpenDialog1.InitialDir := ExtractFileDir(OpenDialog1.FileName);
  Edit1.Text := OpenDialog1.FileName;
  Button1Click(nil);
end;

//=============================================================================
//  SHGetFileInfo関数を使用してファイルのアイコンを取得
//  このアイコンはエクスプローラに描画されているアイコン
//  拡張子に関連付けされアプリのアイコン
//
//  usesにShellAPIが必要
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  LFileName   : String;
  LSHFileInfo : TSHFileInfo;
  LuFlags     : Cardinal;
  LIcon       : TIcon;
begin
  if Edit1.Text = '' then exit;

  LFileName := Edit1.Text;
  Image1.Picture.Assign(nil);

  LIcon := TIcon.Create;
  try
    //取得するアイコンのサイズ等の指定
    LuFlags := 0;
    if CheckBox1.Checked then LuFlags := LuFlags or SHGFI_ICON;
    if CheckBox2.Checked then LuFlags := LuFlags or SHGFI_LARGEICON;
    if CheckBox3.Checked then LuFlags := LuFlags or SHGFI_LINKOVERLAY;
    if CheckBox4.Checked then LuFlags := LuFlags or SHGFI_OPENICON;
    if CheckBox5.Checked then LuFlags := LuFlags or SHGFI_SELECTED;
    if CheckBox6.Checked then LuFlags := LuFlags or SHGFI_SHELLICONSIZE;
    if CheckBox7.Checked then LuFlags := LuFlags or SHGFI_SMALLICON;
    if CheckBox8.Checked then LuFlags := LuFlags or SHGFI_ADDOVERLAYS;

    //指定したフラグでファイルのアイコンを取得
    SHGetFileInfo(PChar(LFileName), 0, LSHFileInfo, SizeOf(LSHFileInfo), LuFlags);
    LIcon.Handle := LSHFileInfo.hIcon;

    //取得したアイコンを描画
    Image1.Canvas.Draw(0, 0, LIcon);
  finally
    FreeAndNil(LIcon);
  end;
end;

end.

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    OpenDialog1: TOpenDialog;
    Image1: TImage;
    Edit1: TEdit;
    SpeedButton1: TSpeedButton;
    Button1: TButton;
    RadioGroup1: TRadioGroup;
    procedure FormCreate(Sender: TObject);
    procedure SpeedButton1Click(Sender: TObject);
    procedure Button1Click(Sender: TObject);
  private
    { Private 宣言 }
    function GetSystemImageList(ASHILValue: Cardinal): HIMAGELIST;
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses
  ShellApi;

{$R *.dfm}

//=============================================================================
//  フォーム生成時の処理
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
begin
  OpenDialog1.InitialDir := ExpandFileName('..\');

  Edit1.Text        := ExtractFilePath(Application.ExeName) + 'Project1.exe';
  Edit1.AutoSelect  := False;
  RadioGroup1.ItemIndex := 3;
end;

//=============================================================================
//  ダイアログを表示してファイルを選択
//=============================================================================
procedure TForm1.SpeedButton1Click(Sender: TObject);
begin
  OpenDialog1.OptionsEx := [];
  OpenDialog1.FileName  := '';
  if not OpenDialog1.Execute then exit;

  OpenDialog1.InitialDir := ExtractFileDir(OpenDialog1.FileName);
  Edit1.Text := OpenDialog1.FileName;
  Button1Click(nil);
end;

//=============================================================================
//  ファイルのアイコンを取得して描画
//  このアイコンはエクスプローラで描画されているアイコン
//
//  TSHFileInfo,SHGetFileInfoの使用にはusesにShellAPIが必要
//  HIMAGELIST,ImageList_GetIconの使用にはusesにCommCtrlが必要
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  LFileName   : string;
  LSHFileInfo : TSHFileInfo;
  LIconIndex  : Integer;
  LhIcon      : TIcon;
  LSHILValue  : Cardinal;
  hImgList    : HIMAGELIST;
begin
  LFileName := Edit1.Text;
  Image1.Picture.Assign(nil);

  LhIcon := TIcon.Create;
  try
    //指定ファイルのアイコンのインデックスを取得
    SHGetFileInfo(PChar(LFileName),
                  0,
                  LSHFileInfo,
                  Sizeof(TSHFileInfo),
                  SHGFI_SYSICONINDEX);
    LIconIndex := LSHFileInfo.iIcon;

    //アイコンのサイズの指定
    LSHILValue := 0;
    if RadioGroup1.ItemIndex = 0 then LSHILValue := SHIL_SMALL;
    if RadioGroup1.ItemIndex = 1 then LSHILValue := SHIL_SYSSMALL;
    if RadioGroup1.ItemIndex = 2 then LSHILValue := SHIL_LARGE;
    if RadioGroup1.ItemIndex = 3 then LSHILValue := SHIL_EXTRALARGE;
    if RadioGroup1.ItemIndex = 4 then LSHILValue := SHIL_JUMBO;

    //指定サイズのアイコンを格納したシステムのイメージリストを取得
    hImgList := GetSystemImageList(LSHILValue);
    //イメージリストから指定インデックスのアイコンのハンドルを取得
    LhIcon.Handle := ImageList_GetIcon(hImgList, LIconIndex, ILD_NORMAL);
    //取得したアイコンを描画
    Image1.Canvas.Draw(0, 0, LhIcon);
  finally
    LhIcon.Free;
  end;
end;

//-----------------------------------------------------------------------------
//  SHGetImageList関数を使用してシステムのイメージリストを取得
//  取得するアイコンのサイズを引数で指定する
//  定数名はShellAPI.pasに定義されている
//
//  Delphi XEにはSHGetImageList関数が実装されているが，32ビットのEXEを64ビット
//  Windowsで実行すると，「特権命令」違反が発生する
//  本コードのようにLoadLivraryでDLLをロードし関数のアドレスを取得して実行する
//  と例外が発生しない
//  64ビットのEXEで実行すれば「特恵命令」は発生しない
//-----------------------------------------------------------------------------
function TForm1.GetSystemImageList(ASHILValue: Cardinal): HIMAGELIST;
type
  TSHGetImageList = function(iImageList: integer;
                             const riid: TGUID;
                             var ppv: Pointer): HRESULT; stdcall;
const
  IID_IImageList: TGUID= '{46EB5926-582E-4017-9FDF-E8998DAA0950}';
var
  LDllHandle      : THandle;
  LSHGetImageList : TSHGetImageList;
begin
  Result := 0;

  LDllHandle := LoadLibrary('Shell32.dll');
  if LDllHandle <> 0 then begin
    try
      LSHGetImageList := GetProcAddress(LDllHandle, 'SHGetImageList');
      if @LSHGetImageList <> nil then begin
        LSHGetImageList(ASHILValue, IID_IImageList, Pointer(Result));
      end;
    finally
      FreeLibrary(LDllHandle);
    end;
  end;
end;

end.

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    OpenDialog1: TOpenDialog;
    Image1: TImage;
    Edit1: TEdit;
    SpeedButton1: TSpeedButton;
    Button1: TButton;
    Label1: TLabel;
    Button2: TButton;
    procedure FormCreate(Sender: TObject);
    procedure SpeedButton1Click(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    { Private 宣言 }
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses
  ShellApi;

{$R *.dfm}

//=============================================================================
//  フォーム生成時の処理
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
begin
  Edit1.Text        := '';
  Edit1.AutoSelect  := False;
end;

//=============================================================================
//  ダイアログを表示してファイルを選択
//=============================================================================
procedure TForm1.SpeedButton1Click(Sender: TObject);
begin
  //.lnkファイルの場合,リンク先でなく.lnkファイルそのものを取得するようにする
  //TOpenDialogは.lnkの場合，デフォルトではリンク先のファイル名を取得する
  OpenDialog1.Options    := OpenDialog1.Options + [ofNoDereferenceLinks];
  OpenDialog1.OptionsEx  := [];
  OpenDialog1.FileName   := '';
  if not OpenDialog1.Execute then exit;

  Edit1.Text := OpenDialog1.FileName;
  Button1Click(nil);
end;

//=============================================================================
//  ファイルのアイコンをExtractAssociatedIcon関数 で取得
//
//  usesにShellAPIが必要
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  LFileName : String;
  LpiIcon   : Word;
  LIcon     : TIcon;
begin
  if Edit1.Text = '' then exit;

  LFileName := Edit1.Text;
  Image1.Picture.Assign(nil);

  LIcon := TIcon.Create;
  try
    LpiIcon := 0;
    LIcon.Handle :=  ExtractAssociatedIcon(HInstance, PChar(LFileName), LpiIcon);
    //取得したアイコンを描画
    Image1.Canvas.Draw(0, 0, LIcon);
    Label1.Caption := 'piIcon : ' + IntToStr(LpiIcon);
  finally
    FreeAndNil(LIcon);
  end;
end;

//=============================================================================
//  ファイルのアイコンをExtractAssociatedIconEx関数 で取得
//  DLLの場合，存在しないインデックスを指定すると例外が発生することがある
//
//  usesにShellAPIが必要
//=============================================================================
procedure TForm1.Button2Click(Sender: TObject);
var
  LFileName    : String;
  LpiIconIndex : Word;
  LpiIconID    : Word;
  LIcon        : TIcon;
begin
  if Edit1.Text = '' then exit;

  LFileName      := Edit1.Text;
  Label1.Caption := '';
  Image1.Picture.Assign(nil);

  LIcon := TIcon.Create;
  try
    LpiIconIndex := 0;
    LpiIconID    := 0;
    LIcon.Handle := ExtractAssociatedIconEx(HInstance,
                                            PChar(LFileName),
                                            LpiIconIndex,
                                            LpiIconID);
    //取得したアイコンを描画
    Image1.Canvas.Draw(0, 0, LIcon);
    Label1.Caption := 'piIconIndex : ' + IntToStr(LpiIconIndex) + sLineBreak
                    + 'plIconID    : ' + IntToStr(LpiIconID);
  finally
    FreeAndNil(LIcon);
  end;
end;

end.

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Button1: TButton;
    Edit1: TEdit;
    SpeedButton1: TSpeedButton;
    OpenDialog1: TOpenDialog;
    CheckBox1: TCheckBox;
    SpinEdit1: TSpinEdit;
    CheckBox2: TCheckBox;
    CheckBox3: TCheckBox;
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure SpeedButton1Click(Sender: TObject);
  private
    { Private 宣言 }
  public
    { Public 宣言 }
  end;

function EnumResNameProc(hModule: HWND; lpszType: LPCTSTR;
                         lpszName: PChar; lParam: PString): LongBool; stdcall;

var
  Form1: TForm1;

implementation

uses
  pngimage;

{$R *.dfm}

type
  //リソース内のグループアイコン用のレコード
  PIconGroupDirEntry = ^TIconGroupDirEntry;
  TIconGroupDirEntry = packed record
    bWidth      : Byte;
    bHeight     : Byte;
    bcolorCount : Byte;
    bReserved   : Byte;
    bPlanes     : Word;
    wBitCount   : Word;
    dwImageSize : DWORD;
    dwId        : Word;
  end;
  TIconGroup = packed record
    idReserved : Word;
    idType     : Word;
    idCount    : Word;
  end;

  //保存アイコンアイコン)用のレコード
  PIconDirEntry = ^TIconDirEntry;
  TIconDirEntry = packed record
    bWidth        : Byte;
    bHeight       : Byte;
    bColorCount   : Byte;
    bReserved     : Byte;
    wPlanes       : Word;
    wBitCount     : Word;
    dwBytesInRes  : DWORD;
    dwImageOffset : DWORD;
  end;

  //アイコンのヘッダ部
  //リソース内と保存アイコン共用
  PIconHeader = ^TIconHeader;
  TIconHeader = packed record
    idReserved : Word;
    idtype     : Word;
    idCount    : Word;
  end;

  PIconImage = ^TIconImage;
  TIconImage = packed record
    iconHeader : TBitmapInfoHeader;
    icColors   : RGBQUAD;
    icXOR      : Byte;
    icAND      : Byte;
  end;

  TIcoGroupItemArray = array of TIconGroupDirEntry;
  TIconDirEntryArray = array of TIconDirEntry;


//-----------------------------------------------------------------------------
//  指定IDのアイコンのデータを取得して引数の値にセット
//  アイコンのデータが格納されているデータのポインタを取得
//  ヘッダ部に続いてアイコンのデータを取得する時に使用する値
//
//  グループ内のアイコンの数だけこのルーチンを実行する
//  つまり,1つづつアイコンを取り出してマルチアイコンにしている
//  したがって,グループの(サイズと色数の違う)アイコンを個別保存することも可能
//  ただし,PNG形式の扱いに注意が必要
//-----------------------------------------------------------------------------
function StoreIconData(hModule: THandle; ID: Word; var pMem: PByte): Boolean;
var
  LhIcon     : HRSRC;
  LhLoadIcon : HRSRC;
  LpLoadIcon : PByte;
begin
  LpLoadIcon := nil;

  //リソースを探してロードする
  LhIcon := FindResource(hModule, MakeIntResource(ID), RT_ICON);
  if LhIcon <> 0 then begin
    LhLoadIcon := LoadResource(hModule, LhIcon);
    if LhLoadIcon <> 0 then begin
      //リソースのロックしてリソースのポインタを取得
      LpLoadIcon := LockResource(LhLoadIcon);
      pMem := LpLoadIcon;
    end;
  end;
  Result := LpLoadIcon <> nil;
end;

//-----------------------------------------------------------------------------
//  EnumResourceNamesのコールバック関数
//  このコールバック関数内でリソースのグループアイコンを取得
//  アイコン情報の構造体に各メンバの値をセット
//  保存先のファイルストリームにヘッダ情報とアイコンデータを書き込む
//
//  usesにpngimageが必要
//-----------------------------------------------------------------------------
function EnumResNameProc(hModule: HWND; lpszType: LPCTSTR; lpszName: LPTSTR;
  lParam: PString): LongBool;
var
  LpResAddr        : PByte;
  LpResDataPoint   : PByte;
  LpIconHeader     : PIconHeader;
  LIcoHeader       : TIconHeader;
  LGroupEntryArray : TIcoGroupItemArray;
  LIcoEntryArray   : TIconDirEntryArray;
  LhGIcon          : HWND;
  LhLoadGIcon      : HWND;
  LHeaderSize      : Cardinal;
  LIcoCount        : Cardinal;
  LSaveFileName    : string;
  LFileStream      : TFileStream;
  LpIconData       : PByte;
  LResStrArg       : string;
  LResIDStr        : string;
  LIconImageRec    : TBytes;
  LBmpHeaderSize   : Cardinal;
  LIsPngImag       : Boolean;
  LNextHeaderPos   : Cardinal;
  LNextImageOffset : Cardinal;
  LStream          : TBytesStream;
  LPngImage        : TPngImage;
  LBitmap          : TBitmap;
  LIcon            : TIcon;
  LIconInfo        : TIconInfo;
  LImgDataSize     : Cardinal;
  i                : Integer;
begin
  Result := True;

  //リソース名のチェック
  //上位WORD(2バイト)が 0ならIDは数値.それ以外は文字列のポインタ
  //ここで作成した文字列は保存用のファイル名として使用する
  LResStrArg := Trim(lparam^);
  if HiWord(Cardinal(lpszName)) = 0 then begin
    LResIDStr := IntToStr(Cardinal(lpszName));
  end else begin
    LResIDStr := lpszName;
  end;
  if not ((LResStrArg = '-1') or (LResStrArg = '0') or (LResStrArg = '')) then begin
    if (LResStrArg <> LResIDStr) then exit;
  end;


  //グループアイコン(引数のリソース識別子lpszName)のリソースを検索
  LhGIcon := FindResource(hModule, lpszName, RT_GROUP_ICON);
  if LhGIcon = 0 then exit;

  //見つけたリソースをロード
  LhLoadGIcon := LoadResource(hModule, LhGIcon);
  if LhLoadGIcon = 0 then Exit;

  //リソースをロックして、メモリアドレスを取得
  LpResAddr := LockResource(LhLoadGIcon);

  //アイコンファイルヘッダ読み出してアイコン数を取得
  LpIconHeader := PIconHeader(LpResAddr);
  LIcoCount    := LpIconHeader.idCount;

  //構造体のサイズを設定
  SetLength(LGroupEntryArray, LIcoCount);
  SetLength(LIcoEntryArray, LIcoCount);
  LpResDataPoint := Pointer(Cardinal(LpIconHeader) + SizeOf(TIconHeader));
  //構造体の情報をコピー
  CopyMemory(LGroupEntryArray, LpResDataPoint, SizeOf(TIconGroupDirEntry) * LIcoCount);

  //保存用のファイル名を生成して保存用のファイルストリームを作成
  //ファイル名にはリソースのIDの値を先頭に付ける
  LSaveFileName := ExtractFilePath(Application.ExeName)
                 + 'ICONS\ID_' + LResIDStr + '.ico';
  ForceDirectories(ExtractFileDir(LSaveFileName));

  //アイコン画像保存用ファイルストリーム作成
  LFileStream := TFileStream.Create(LSaveFileName, fmCreate);
  LFileStream.Position := 0;


  LStream   := TBytesStream.Create;
  LPngImage := TPngImage.Create;
  LBitmap   := TBitmap.Create;
  LIcon     := TIcon.Create;
  try
    //アイコンファイルヘッダの情報設定とヘッダの書き込み
    LIcoHeader.idReserved := 0;
    LIcoHeader.idCount    := LIcoCount;
    LIcoHeader.idtype     := 1;
    LFileStream.Write(LIcoHeader, SizeOf(TIconHeader));

    //アイコンファイルのヘッダサイズの計算
    LHeaderSize := SizeOf(TIconHeader) + SizeOf(TIconDirEntry) * LIcoCount;

    //保存先のヘッダの書き込み開始位置の初期値と
    //保存先の画像データ書き込み開始位置の初期値
    LNextHeaderPos   := LFileStream.Position;
    LNextImageOffset := LHeaderSize;

    for i := 0 to LIcoCount - 1 do begin
      if StoreIconData(hModule, LGroupEntryArray[i].dwId, LpIconData) then begin

        //画像データの先頭にあるBitmapInfoHeader構造体のサイズを調べる
        //BitmapInfoHeaderがない場合はPNG形式の画像データ
        SetLength(LIconImageRec, SizeOf(TIconImage));
        CopyMemory(LIconImageRec, LpIconData, SizeOf(TIconImage));
        LBmpHeaderSize := PIconImage(LIconImageRec)^.iconHeader.biSize;
        if LBmpHeaderSize = SizeOf(TBitmapInfoHeader) then begin
          LIsPngImag := False;
        end else begin
          LIsPngImag := True;
        end;

        //構造体の情報の書き込み
        LIcoEntryArray[i].bWidth      := LGroupEntryArray[i].bWidth;
        LIcoEntryArray[i].bHeight     := LGroupEntryArray[i].bHeight;
        LIcoEntryArray[i].bColorCount := LGroupEntryArray[i].bcolorCount;
        LIcoEntryArray[i].wBitCount   := LGroupEntryArray[i].wBitCount;
        LIcoEntryArray[i].wPlanes     := LGroupEntryArray[i].bPlanes;

        //PNG画像をビットマップ形式でファイル内に格納する場合
        //PNG-->BMP--ICONの順で変換
        if LIsPngImag and Form1.CheckBox3.Checked then begin
          //PNG画像のデータをメモリストリームに読み込む
          LStream.SetSize(LGroupEntryArray[i].dwImageSize);
          CopyMemory(LStream.Memory, LpIconData, LGroupEntryArray[i].dwImageSize);
          LPngImage.LoadFromStream(LStream);

          //ビットマップに変換
          //Drawすると背景が初期値の白になる
          LBitmap.Assign(LPngImage);

          //TIconInfo構造体の値をセットしてICONに変換
          FillChar(LIconInfo, SizeOf(TIconInfo), #0);
          LIconInfo.fIcon    := True;
          LIconInfo.xHotspot := LBitmap.Width;
          LIconInfo.yHotspot := LBitmap.Height;
          LIconInfo.hbmColor := LBitmap.Handle;
          LIconInfo.hbmMask  := LBitmap.MaskHandle;
          LIcon.Handle := CreateIconIndirect(LIconInfo);

          //変換したらメモリストリームに格納
          LStream.Position := 0;
          LIcon.SaveToStream(LStream);

          //ヘッダ部を除いた画像テータ部分のみのサイズ
          LImgDataSize := LStream.Size - SizeOf(TIconHeader) - SizeOf(TIconDirEntry);
          //新しいデータサイズとデータ位置までの値をヘッダ部のメンバにセット
          LIcoEntryArray[i].dwBytesInRes  := LImgDataSize;
          LIcoEntryArray[i].dwImageOffset := LNextImageOffset;
        end else begin
          //PNG形式ではない場合(ビットマップ形式)
          //データサイズとデータ位置までの値をヘッダ部のメンバにセット
          LIcoEntryArray[i].dwBytesInRes  := LGroupEntryArray[i].dwImageSize;
          LIcoEntryArray[i].dwImageOffset := LNextImageOffset;

          LImgDataSize := LIcoEntryArray[i].dwBytesInRes;
          LStream.SetSize(LImgDataSize);
          CopyMemory(LStream.Memory, LpIconData, LImgDataSize);
        end;

        //ヘッダ部の書き込み位置へ移動してヘッダ部のデータを書き込む
        LFileStream.Position := LNextHeaderPos;
        LFileStream.Write(LIcoEntryArray[i], SizeOf(TIconDirEntry));
        LNextHeaderPos := LNextHeaderPos + SizeOf(TIconDirEntry);

        //ヘッダ部を書き込んだら画像データを書き込む
        LFileStream.Position := LNextImageOffset;
        if LIsPngImag and Form1.CheckBox3.Checked then begin
          LFileStream.Write(LStream.Bytes[SizeOf(TIconHeader) + SizeOf(TIconDirEntry)],
                            LImgDataSize);
        end else begin
          LFileStream.Write(LStream.Bytes[0], LImgDataSize);
        end;
        LNextImageOffset := LNextImageOffset + LImgDataSize;
      end;
      Application.ProcessMessages;
    end;
  finally
    FreeAndNil(LFileStream);
    FreeAndNil(LStream);
    FreeAndNil(LIcon);
    FreeAndNil(LBitmap);
    FreeAndNil(LPngImage);
  end;

  //列挙の終了条件を判定
  if (LResStrArg = '0') or (LResStrArg = '') then Result := False;
  if (LResStrArg = LResIDStr) then Result := False;
end;

//=============================================================================
//  フォーム生成時の処理
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
begin
  Edit1.Text := '';
  SpinEdit1.Value := 0;

  OpenDialog1.InitialDir := ExpandFileName('..\');
  OpenDialog1.Filter := 'EXE, DLL ファイル |*.exe;*.dll|'
                      + '実行ファイル (*.exe)|*.exe|DLL ファイル (*.dll)|*.dll';
end;

//=============================================================================
//  ダイアログを表示して,アイコンを取得するEXEまたはDLLファイルを選択
//=============================================================================
procedure TForm1.SpeedButton1Click(Sender: TObject);
begin
  if OpenDialog1.Execute then begin
    Edit1.Text := OpenDialog1.FileName;
    OpenDialog1.InitialDir := ExtractFileDir(Edit1.Text));
  end;
end;

//=============================================================================
//  EXE,DLL内のアイコンのアイコンを取得して保存
//  取得するのはicon Groupのアイコンのみ
//
//  本アプリのフォルダ内にICONSというディレクトリを作成してそこに保存
//  保存先フォルダ作成と保存はコールバック関数内で行う(ディレクトリは自動作成)
//
//  Button1のDefaultプロパティをTrueにしているので,[Enter]で実行可能
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  LFilePath : string;
  LResName  : string;
  LhModule  : THandle;
begin
  LFilePath := Edit1.Text;

  //---------------------------------------------------------------------------
  //  LResName(リソース名)の指定方法
  //
  //  '0'または空文字の場合は最初に検出したアイコンのみを取得
  //  '-1'にすると全てのアイコンを取得
  //  名前を指定すればその名前のアイコンだけを取得
  //  (Delphi製のEXEのアイコンの場合は'MAINICON'だが,最初のアイコン取得でOK)
  //---------------------------------------------------------------------------

  LResName := IntToStr(SpinEdit1.Value);
  //チェックボックスの設定を優先
  if CheckBox1.Checked then LResName := 'MAINICON';
  if CheckBox2.Checked then LResName := '-1';

  //EXEまたはDLLをロードする
  //LoadLibrary関数ではなくLoadLibraryEx関数を使用する
  LhModule := LoadLibraryEx(PChar(LFilePath),
                            0,
                            LOAD_LIBRARY_AS_DATAFILE or
                            LOAD_WITH_ALTERED_SEARCH_PATH);
  try
    //EnumResourceNames関数を実行してリソースを列挙する
    if LhModule <> 0 then begin
      EnumResourceNames(LhModule, RT_GROUP_ICON, @EnumResNameProc, LPARAM(@LResName));
    end;
  finally
    FreeLibrary(LhModule);
  end;
end;

end.

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Image1: TImage;
    Panel1: TPanel;
    ListBox1: TListBox;
    Panel2: TPanel;
    Edit1: TEdit;
    SpeedButton1: TSpeedButton;
    OpenPictureDialog1: TOpenPictureDialog;
    CheckBox1: TCheckBox;
    procedure SpeedButton1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure Edit1KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
    procedure ListBox1Click(Sender: TObject);
  private
    { Private 宣言 }
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses
  plExtractMultiIcon;

{$R *.dfm}

//=============================================================================
//  フォーム生成時の処理
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
begin
  ActiveControl := Edit1;

  Edit1.Text := ExpandFileName('..\Multi.ico');
  OpenPictureDialog1.InitialDir := ExtractFileDir(Edit1.Text);
end;

//=============================================================================
//  マルチアイコンファイルの情報を取得とアイコンの保存
//  添付のplExtractMultiIconユニットを使用
//
//  CheckBox1のOnClickイベントと共有
//=============================================================================
procedure TForm1.SpeedButton1Click(Sender: TObject);
var
  LIconFilePath  : string;
  LOriginStream  : TBytesStream;
  LIconEntryRec  : TIconDirEntryArray;
  LIconCount     : Integer;
  LIconWidth     : Integer;
  LIconHeight    : Integer;
  LBitCount      : Integer;
  LText          : string;
  LSaveFileDir   : string;
  i              : Integer;
begin
  if Sender is TSpeedButton then begin
    if not OpenPictureDialog1.Execute then exit;
    Edit1.Text := OpenPictureDialog1.FileName;
    OpenPictureDialog1.InitialDir := ExtractFileDir(OpenPictureDialog1.FileName);
  end;
  if Trim(Edit1.Text) = '' then exit;

  Image1.Picture.Assign(nil);
  LIconFilePath := Edit1.Text;
  LOriginStream := TBytesStream.Create;
  try
    //ストリームにアイコンファイルを読み込む
    LOriginStream.LoadFromFile(LIconFilePath);

    LIconCount := GetMultiIconEntryInfo(LOriginStream, LIconEntryRec);

    ListBox1.Items.Clear;
    ListBox1.Items.BeginUpdate;

    ListBox1.Items.Add(' Entry  width  Height  Bits ');
    ListBox1.Items.Add('----------------------------');
    for i := 0 to LIconCount - 1 do begin
      LIconWidth  := LIconEntryRec[i].hWidth;
      LIconHeight := LIconEntryRec[i].hHeight;
      if LIconWidth  = 0 then LIconWidth  := 256;
      if LIconHeight = 0 then LIconHeight := 256;

      if LIconEntryRec[i].wBitCount = 0 then begin
        LBitCount := LIconEntryRec[i].bColorCount;
      end else begin
        LBitCount := LIconEntryRec[i].wBitCount;
      end;

      LText := Format('%4d%8d%7d%7d', [i, LIconWidth, LIconHeight, LBitCount]);
      ListBox1.Items.Add(LText);
    end;
    ListBox1.Items.EndUpdate;

    //マルチアイコンファイルから個別にアイコンを取り出してディスクに保存
    LSaveFileDir := ExpandFileName('ICONS');
    SaveMultiIconToFiles(LOriginStream, LSaveFileDir, CheckBox1.Checked);
  finally
    FreeAndNil(LOriginStream);
  end;
end;

//=============================================================================
//  Edit1のOnKeyDownイベント処理
//  [Enter]でEit1に表示しているファイルを読み込んで情報を表示
//=============================================================================
procedure TForm1.Edit1KeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
  if Key = VK_RETURN then begin
    SpeedButton1Click(Sender);
    Key := 0;
  end;
end;

//=============================================================================
//  ListBox1のOnClickイベント処理
//  選択したアイコンを描画
//  添付のplExtractMultiIconユニットを使用
//=============================================================================
procedure TForm1.ListBox1Click(Sender: TObject);
var
  LIconFilePath : string;
  LStream       : TBytesStream;
  LPicture      : TPicture;
begin
  Image1.Picture.Assign(nil);
  if Trim(Edit1.Text) = '' then exit;
  if ListBox1.ItemIndex < 2 then exit;

  LIconFilePath := Edit1.Text;
  LStream  := TBytesStream.Create;
  LPicture := TPicture.Create;
  try
    //ストリームにアイコンファイルを読み込む
    LStream.LoadFromFile(LIconFilePath);

    GetPictureFromMultiIcon(LStream, ListBox1.ItemIndex - 2, LPicture);
    Image1.Picture.Assign(LPicture);
  finally
    FreeAndNil(LStream);
    FreeAndNil(LPicture);
  end;
end;

end.

unit plExtractMultiIcon;

interface

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

type
  //アイコンファイルのヘッダ部
  PIconFileHeader = ^TIconFileHeader;
  TIconFileHeader = packed record
    idReserved : Word;
    idType     : Word;
    idCount    : Word;
  end;

  //各アイコンの情報用レコード型
  PIconDirEntry = ^TIconDirEntry;
  TIconDirEntry = packed record
    hWidth        : Byte;
    hHeight       : Byte;
    bColorCount   : Byte;
    bReserved     : Byte;
    wPlanes       : Word;
    wBitCount     : Word;
    dwBytesInRes  : DWORD;
    dwImageOffset : DWORD;
  end;

  PIconImage = ^TIconImage;
  TIconImage = packed record
    iconHeader : TBitmapInfoHeader;
    icColors   : RGBQUAD;
    icXOR      : Byte;
    icAND      : Byte;
  end;

  PIconDirEntryArray = ^TIconDirEntryArray;
  TIconDirEntryArray = array of TIconDirEntry;

function GetMultiIconEntryInfo(AFileName: string;
  var AEntryRecArray: TIconDirEntryArray): Cardinal; overload;
function GetMultiIconEntryInfo(ASrcStream: TBytesStream;
  var AEntryRecArray: TIconDirEntryArray): Cardinal; overload;
function SaveMultiIconToFiles(AFileName: string; ASaveDir: string;
  AIsSaveIconFormat: Boolean): Cardinal; overload;
function SaveMultiIconToFiles(ASrcStream: TBytesStream; ASaveDir: string;
  AIsSaveIconFormat: Boolean): Cardinal; overload;
function GetPictureFromMultiIcon(AFileName: string; AIconNo: Cardinal;
  APicture: TPicture): Boolean; overload;
function GetPictureFromMultiIcon(ASrcStream: TBytesStream; AIconNo: Cardinal;
  APicture: TPicture): Boolean; overload;

implementation

uses
  pngimage;

//-----------------------------------------------------------------------------
//  マルチアイコンファイルから情報を取得
//  引数類については次の関数を参照
//-----------------------------------------------------------------------------
function GetMultiIconEntryInfo(AFileName: string;
  var AEntryRecArray: TIconDirEntryArray): Cardinal;
var
  LSrcStream : TBytesStream;
begin
  LSrcStream := TBytesStream.Create;
  try
    LSrcStream.LoadFromFile(AFileName);
    Result := GetMultiIconEntryInfo(LSrcStream, AEntryRecArray);
  finally
    FreeAndNil(LSrcStream);
  end;
end;

//-----------------------------------------------------------------------------
//  マルチアイコンファイルのストリームから情報を取得
//  引数のエントリ構造体の配列に各アイコンのメンバ値をセットして返す
//
//  ASrcStream     : マルチアイコンファイルの内容を格納したストリーム
//  AEntryRecArray : TIconDirEntry構造体の配列
//  戻り値は取得したアイコンの数
//-----------------------------------------------------------------------------
function GetMultiIconEntryInfo(ASrcStream: TBytesStream;
  var AEntryRecArray: TIconDirEntryArray): Cardinal;
var
  LIcoHeaderRec : TIconFileHeader;
begin
  ASrcStream.Position := 0;
  //ストリームからアイコンのヘッダを読み込む
  ASrcStream.ReadBuffer(LIcoHeaderRec, SizeOf(LIcoHeaderRec));
  Result := LIcoHeaderRec.idCount;

  //アイコンのエントリ情報を読み込む
  SetLength(AEntryRecArray, Result);
  ASrcStream.ReadBuffer(AEntryRecArray[0], SizeOf(TIconDirEntry) * Result);
end;

//-----------------------------------------------------------------------------
//  マルチアイコンファイル内の各アイコンを取り出してディスクに保存
//  引数類については次の関数を参照
//-----------------------------------------------------------------------------
function SaveMultiIconToFiles(AFileName: string; ASaveDir: string;
  AIsSaveIconFormat: Boolean): Cardinal;
var
  LSrcStream : TBytesStream;
begin
  LSrcStream := TBytesStream.Create;
  try
    LSrcStream.LoadFromFile(AFileName);
    Result := SaveMultiIconToFiles(LSrcStream, ASaveDir, AIsSaveIconFormat);
  finally
    FreeAndNil(LSrcStream);
  end;
end;

//-----------------------------------------------------------------------------
//  マルチアイコンファイルのストリーム内の各アイコンを取り出してディスクに保存
//
//  AFileName         : マルチアイコンファイルの内容を格納したストリーム
//  ASaveDir          : 保存先のディレクトリ名(内部で自動作成)
//  AIsSaveIconFormat : 256x256のPNG形式のアイコンをICON形式で保存するか
//                      Trueならビットマップ形式のフォーマットで保存
//                      Falseなら元のファイル内に格納されている形式
//                      ビットマップ形式で保存するとファイルサイズは大きくなる
//                      PNG形式のアイコンはTICONでは扱えない
//  戻り値は取得したアイコンの数
//
//  usesにpngimageが必要
//-----------------------------------------------------------------------------
function SaveMultiIconToFiles(ASrcStream: TBytesStream; ASaveDir: string;
  AIsSaveIconFormat: Boolean): Cardinal;
var
  LIcoHeaderRec  : TIconFileHeader;
  LIcoDirRec     : array of TIconDirEntry;
  LIconCount     : Integer;
  LIconWidth     : Integer;
  LIconHeight    : Integer;
  LBitCount      : Integer;
  LSaveStream    : TBytesStream;
  LPngDataStream : TBytesStream;
  LIcoSaveDirRec : TIconDirEntry;
  LIcoImageRec   : TIconImage;
  LImgStartPos   : Integer;
  LImgSize       : Integer;
  LIsPngImage    : Boolean;
  LIcon          : TIcon;
  LPngImage      : TPngImage;
  LBitmap        : TBitmap;
  LIconInfo      : TIconInfo;
  LSaveFileName  : string;
  i              : Integer;
begin
  Result := 0;
  if Trim(ASaveDir) = '' then exit;
  if ASrcStream = nil then exit;
  if ASrcStream.Size = 0 then exit;

  ASrcStream.Position := 0;
  //ストリームからアイコンのヘッダを読み込む
  ASrcStream.ReadBuffer(LIcoHeaderRec, SizeOf(LIcoHeaderRec));
  LIconCount := LIcoHeaderRec.idCount;
  //アイコンのエントリ情報を読み込む
  SetLength(LIcoDirRec, LIconCount);
  ASrcStream.ReadBuffer(LIcoDirRec[0], SizeOf(TIconDirEntry) * LIconCount);

  //保存先のディレクトリを作成
  ForceDirectories(ASaveDir);

  LSaveStream    := TBytesStream.Create;
  LPngDataStream := TBytesStream.Create;
  LIcon       := TIcon.Create;
  LPngImage   := TPngImage.Create;
  LBitmap     := TBitmap.Create;
  try
    for i := 0 to LIconCount - 1 do begin
      //個別のアイコンデータを格納するストリームを初期化
      LSaveStream.Clear;

      //アイコン数を1にしてヘッダ部の該当メンバの値を変更
      LIcoHeaderRec.idCount := 1;
      LSaveStream.WriteBuffer(LIcoHeaderRec, SizeOf(TIconFileHeader));

      //エントリ情報をセットしてストリームに書き込む
      LIcoSaveDirRec.hWidth        := LIcoDirRec[i].hWidth;
      LIcoSaveDirRec.hHeight       := LIcoDirRec[i].hHeight;
      LIcoSaveDirRec.wBitCount     := LIcoDirRec[i].wBitCount;
      LIcoSaveDirRec.bColorCount   := LIcoDirRec[i].bColorCount;
      LIcoSaveDirRec.dwBytesInRes  := LIcoDirRec[i].dwBytesInRes;
      LIcoSaveDirRec.wPlanes       := LIcoDirRec[i].wPlanes;

      LIcoSaveDirRec.dwImageOffset := SizeOf(TIconFileHeader)
                                     + SizeOf(TIconDirEntry);
      LSaveStream.WriteBuffer(LIcoSaveDirRec, SizeOf(TIconDirEntry));

      //TIconImage構造体のデータを取得
      //PNG形式かどうかを調べるために使用
      ASrcStream.Position := LIcoDirRec[i].dwImageOffset;
      ASrcStream.ReadBuffer(LIcoImageRec, SizeOf(TIconImage));

      LImgStartPos := LIcoDirRec[i].dwImageOffset;
      LImgSize     := LIcoDirRec[i].dwBytesInRes;

      //画像データを保存用のストリームに書き込む
      LSaveStream.WriteBuffer(ASrcStream.Bytes[LImgStartPos], LImgSize);

      //IconImageヘッダ(BitmapInfoHeaderヘッダ)のサイズを調べる
      if LIcoImageRec.iconHeader.biSize = SizeOf(TBitmapInfoHeader) then begin
        //ビットマップ形式のアイコン
        LIsPngImage := False;
      end else begin
        //ビットマップヘッダの情報がない時は256x256のPNG形式のデータと判定
        LIsPngImage := True;

        //PNG画像データは別のストリームに格納
        //PNG形式をビットマップ形式で保存する時に使用する
        LPngDataStream.Clear;
        LPngDataStream.WriteBuffer(ASrcStream.Bytes[LImgStartPos], LImgSize);
      end;

      if LIsPngImage then begin
        LPngDataStream.Position := 0;
        LPngImage.LoadFromStream(LPngDataStream);

        LIconWidth  := LPngImage.Width;
        LIconHeight := LPngImage.Height;
        LBitCount   := LPngImage.Header.BitDepth;

        if AIsSaveIconFormat then begin
          LPngDataStream.Position := 0;
          LPngImage.LoadFromStream(LPngDataStream);
          //PNG画像をビットマップ形式のアイコンで保存する場合
          //PNG-->BMP-->ICONの順で変換する
          LBitmap.Assign(LPngImage);

          //TIconInfo構造体の値をセット
          FillChar(LIconInfo, SizeOf(TIconInfo), #0);
          LIconInfo.fIcon    := True;
          LIconInfo.xHotspot := LBitmap.Width;
          LIconInfo.yHotspot := LBitmap.Height;
          LIconInfo.hbmColor := LBitmap.Handle;
          LIconInfo.hbmMask  := LBitmap.MaskHandle;

          LIcon.Handle := CreateIconIndirect(LIconInfo );
          //メモリストリームに格納
          LIcon.SaveToStream(LSaveStream);
        end;
      end else begin
        LIconWidth  := LIcoImageRec.iconHeader.biWidth;
        LIconHeight := LIcoImageRec.iconHeader.biHeight;
        LBitCount   := LIcoImageRec.iconHeader.biBitCount;
      end;

      //保存ファイル名を生成して保存
      LSaveFileName := IncludeTrailingPathDelimiter(ASaveDir) +  IntToStr(i) + '_'
                     + IntToStr(LIconWidth) + 'x' + IntToStr(LIconHeight) + '_'
                     + IntToStr(LBitCount) + 'bit.ico';
      LSaveStream.SaveToFile(LSaveFileName);

      Application.ProcessMessages;
    end;
  finally
    FreeAndNil(LSaveStream);
    FreeAndNil(LPngDataStream);
    FreeAndNil(LIcon);
    FreeAndNil(LPngImage);
    FreeAndNil(LBitmap);
  end;
  Result := LIconCount;
end;

//-----------------------------------------------------------------------------
//  マルチアイコンファイル内の指定番目のアイコン画像を取得
//  引数類については次の関数を参照
//-----------------------------------------------------------------------------
function GetPictureFromMultiIcon(AFileName: string; AIconNo: Cardinal;
  APicture: TPicture): Boolean;
var
  LStream  : TBytesStream;
begin
  LStream := TBytesStream.Create;
  try
    LStream.LoadFromFile(AFileName);
    Result := GetPictureFromMultiIcon(LStream, AIconNo, APicture);
  finally
    FreeAndNil(LStream);
  end;
end;

//-----------------------------------------------------------------------------
//  マルチアイコンファイルのストリーム内の指定番目のアイコン画像を取得
//  取得した画像は引数のTPictureオブジェクトに格納する
//  PNG形式のアイコンはTPngImageのオブジェクト
//  ビットマップ形式のアイコンはTIconオブジェクト
//
//  AFileName : マルチアイコンファイルの内容を格納したストリーム
//  AIconNo   : 何番目のアイコンを取得するかの指定
//              0ベースの値(1番目のアイコン画像は0)
//  APicture  : TPictureオブジェクト
//              ここにアイコン画像を格納して返す
//  取得した画像を保存すれば指定番目の画像の保存となる
//
//  usesにpngimageが必要
//-----------------------------------------------------------------------------
function GetPictureFromMultiIcon(ASrcStream: TBytesStream; AIconNo: Cardinal;
  APicture: TPicture): Boolean;
var
  LIcoHeaderRec   : TIconFileHeader;
  LSaveEntryRec   : TIconDirEntry;
  LIconImageRec   : TIconImage;
  LSrcImgStartPos : Integer;
  LSrcImageSize   : Cardinal;
  LSaveStream     : TBytesStream;
  LIsPngImage     : Boolean;
  LIcon           : TIcon;
  LPngImage       : TPngImage;
begin
  Result := False;
  if ASrcStream = nil then exit;
  if ASrcStream.Size = 0 then exit;

  LSaveStream := TBytesStream.Create;
  LIcon       := TIcon.Create;
  LPngImage   := TPngImage.Create;
  try
    //アイコンデータを格納するストリームの書き込み位置を0に
    LSaveStream.Position := 0;

    //ストリームからアイコンのヘッダを読み込む
    ASrcStream.Position := 0;
    ASrcStream.ReadBuffer(LIcoHeaderRec, SizeOf(LIcoHeaderRec));
    //アイコン数を1にしてヘッダ部の該当メンバの値を保存用ストリームに書き込む
    LIcoHeaderRec.idCount := 1;
    LSaveStream.WriteBuffer(LIcoHeaderRec, SizeOf(TIconFileHeader));

    //指定番目のアイコンのエントリ情報を読み込む
    ASrcStream.Position := SizeOf(LIcoHeaderRec) + SizeOf(TIconDirEntry) * AIconNo;
    ASrcStream.ReadBuffer(LSaveEntryRec, SizeOf(TIconDirEntry));

    //元の値を退避
    LSrcImgStartPos := LSaveEntryRec.dwImageOffset;
    LSrcImageSize   := LSaveEntryRec.dwBytesInRes;

    //画像データの開始位置を保存用ストリームに書き込む
    LSaveEntryRec.dwImageOffset := SizeOf(TIconFileHeader) + SizeOf(TIconDirEntry);
    LSaveStream.WriteBuffer(LSaveEntryRec, SizeOf(TIconDirEntry));


    //TIconImage構造体のデータを取得
    //PNG形式かどうかを調べるために使用
    ASrcStream.Position := LSrcImgStartPos;
    ASrcStream.ReadBuffer(LIconImageRec, SizeOf(TIconImage));

    //IconImageヘッダ(BitmapInfoHeaderヘッダ)のサイズを調べる
    if LIconImageRec.iconHeader.biSize = SizeOf(TBitmapInfoHeader) then begin
      LIsPngImage := False;
      //画像データ格納用のストリームに現在の位置から書き込む
      LSaveStream.WriteBuffer(ASrcStream.Bytes[LSrcImgStartPos], LSrcImageSize);
    end else begin
      //ビットマップヘッダの情報がない場合はPNG形式画像と判定
      LIsPngImage := True;
      //画像データ格納用のストリームに書き込む
      //PNG形式の画像にはEntry部はないので書き込み対象から除外
      LSaveStream.Position := 0;
      LSaveStream.WriteBuffer(ASrcStream.Bytes[LSrcImgStartPos], LSrcImageSize);
    end;

    LSaveStream.Position := 0;
    if LIsPngImage then begin
      LPngImage.LoadFromStream(LSaveStream);
      APicture.Assign(LPngImage);
    end else begin
      LIcon.LoadFromStream(LSaveStream);
      APicture.Assign(LIcon);
    end;
    Result := True;
  finally
    FreeAndNil(LSaveStream);
    FreeAndNil(LIcon);
    FreeAndNil(LPngImage);
  end;
end;

end.

uses
  KIcon;

{$R *.dfm}

//=============================================================================
//  LKIcon.LoadFromAssocFileの使用例
//  ファイルのアイコンをマルチアイコンファイルで取得して保存
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  LFilePath     : string;
  LKIcon        : TKIcon;
  LSaveFilePath : string;
begin
  LFilePath     := Application.ExeName;
  LSaveFilePath := 'FileIcon-' + ExtractFileName(LFilePath) + '.ico';

  LKIcon := TKIcon.Create;
  try
    LKIcon.LoadFromAssocFile(LFilePath);
    LKIcon.SaveToFile(LSaveFilePath);
  finally
    FreeAndNil(LKIcon);
  end;
end;

uses
  KIcon;

{$R *.dfm}

//=============================================================================
//  LKIcon.LoadFromAssocExtensionの使用例
//  拡張子に関連付けされたアイコンをマルチアイコンファイルで取得して保存
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  LFileExt      : string;
  LKIcon        : TKIcon;
  LSaveFilePath : string;
begin
  LFileExt := '.xls';
  LSaveFilePath := 'FileExt-' + Copy(LFileExt, 2, Length(LFileExt)) + '.ico';

  LKIcon := TKIcon.Create;
  try
    LKIcon.LoadFromAssocExtension(LFileExt);
    LKIcon.SaveToFile(LSaveFilePath);
  finally
    FreeAndNil(LKIcon);
  end;
end;

function EnumResNameProc(hModule: HWND;
                         lpszType: LPCTSTR;
                         lpszName: PChar;
                         lParam: PString): LongBool; stdcall;

var
  Form1: TForm1;

implementation

uses
  KIcon;

{$R *.dfm}

//=============================================================================
//  LKIcon.LoadFromResourceの使用例
//  EXE,DLL内のアイコンを列挙して保存
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  LFilePath : string;
  LhModule  : THandle;
begin
  //システム的にパスが通っているのでディレクトリ名は省略可能
  LFilePath := 'shell32.dll';

  //EXEまたはDLLをロードする
  //LoadLibrary関数ではなくLoadLibraryEx関数を使用する
  LhModule := LoadLibraryEx(PChar(LFilePath),
                            0,
                            LOAD_LIBRARY_AS_DATAFILE or
                            LOAD_WITH_ALTERED_SEARCH_PATH);
  try
    //EnumResourceNames関数を実行してリソースを列挙する
    if LhModule <> 0 then begin
      ForceDirectories(ExtractFilePath(Application.ExeName) + 'ICONS');
      EnumResourceNames(LhModule, RT_GROUP_ICON, @EnumResNameProc, 0);
    end;
  finally
    FreeLibrary(LhModule);
  end;
  ShowMessage('END');
end;

//-----------------------------------------------------------------------------
//  EnumResourceNamesのコールバック関数
//  このコールバック関数内でリソースのアイコンを取得して保存
//-----------------------------------------------------------------------------
function EnumResNameProc(hModule: HWND; lpszType: LPCTSTR; lpszName: LPTSTR;
  lParam: PString): LongBool;
var
  LKIcon        : TKIcon;
  LResIDStr     : string;
  LSaveFileName : string;
begin
  Result := True;

  LKIcon := TKIcon.Create;
  try
    //リソース名のチェック
    //上位WORD(2バイト)が 0ならIDは数値.それ以外は文字列のポインタ
    if HiWord(Cardinal(lpszName)) = 0 then begin
      LResIDStr := IntToStr(Cardinal(lpszName));
      LKIcon.LoadFromResource(hModule, cardinal(lpszName));
    end else begin
      LResIDStr := lpszName;
      LKIcon.LoadFromResource(hModule, LResIDStr);
    end;

    //保存用のファイル名を生成して保存
    //ファイル名にはリソースのIDの値を先頭に付ける
    LSaveFileName := ExtractFilePath(Application.ExeName)
                   + 'ICONS\ID_' + LResIDStr + '.ico';
    LKIcon.SaveToFile(LSaveFileName);
  finally
    FreeAndNil(LKIcon);
  end;
end;

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    { Private 宣言 }
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses
  ShellAPI,
  ShlObj;

{$R *.dfm}

//=============================================================================
//  ImageMagickを利用したマルチアイコンファイルの作成
//  usesにShellAPI, ShlObjが必要
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  LCurDir     : string;
  LCmdExeName : string;
  LCmdParams  : string;
begin
  LCurDir := ExpandFileName('..\');

  LCmdExeName := 'convert.exe';
  //アイコンのファイル名をコマンドのパラメータとして指定
  //最後が保存ファイル名
  LCmdParams := LCurDir + '16.ico'
              + ' ' + LCurDir + '24.ico'
              + ' ' + LCurDir + '32.ico'
              + ' ' + LCurDir + '48.ico'
              + ' ' + LCurDir + '64.ico'
              + ' ' + LCurDir + '128.ico'
              + ' ' + LCurDir + '256.ico'
              + ' ' + LCurDir + 'Multi.ico';

  //マルチアイコンファイル作成
  ShellExecute(Handle, '', PChar(LCmdExeName), PChar(LCmdParams), nil, SW_HIDE);

  //念のためアイコンの変更をシステムに通知
  //別のマルチアイコンを同じ名前で作成した保存した場合,更新されないことがある
  //(筆者のWindows 7の場合)
  SHChangeNotify(SHCNE_ASSOCCHANGED, SHCNF_FLUSH, nil, nil);
end;

end.

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Image1: TImage;
    Edit1: TEdit;
    SpeedButton1: TSpeedButton;
    OpenPictureDialog1: TOpenPictureDialog;
    RadioGroup1: TRadioGroup;
    procedure FormCreate(Sender: TObject);
    procedure SpeedButton1Click(Sender: TObject);
    procedure Edit1KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
  private
    { Private 宣言 }
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses
  IconEx;

{$R *.dfm}

//=============================================================================
//  フォーム生成時の処理
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
begin
  Edit1.Text        := '';
  Edit1.AutoSelect  := False;

  RadioGroup1.ItemIndex := 2;
  OpenPictureDialog1.InitialDir := ExpandFileName('..\');
end;

//=============================================================================
//  ダイアログを表示してファイルを選択し,アイコンを描画
//  TIconEx(中村拓男氏作)を使用する例
//
//  [添付のマルチアイコンファイルの場合の動作]
//  256サイズを指定しても128サイズのアイコンが読み込まれる
//
//  usesにIcoExが必要
//=============================================================================
procedure TForm1.SpeedButton1Click(Sender: TObject);
var
  LFileName : string;
  LIcon     : TIconEx;
  LIconSize : Integer;
begin
  if Sender is TSpeedButton then begin
    OpenPictureDialog1.OptionsEx  := [];
    OpenPictureDialog1.FileName   := '';
    if not OpenPictureDialog1.Execute then exit;

    Edit1.Text := OpenPictureDialog1.FileName;
    OpenPictureDialog1.InitialDir := ExtractFileDir(Edit1.Text);
  end;
  if Edit1.Text = '' then exit;

  LFileName := Edit1.Text;
  Image1.Picture.Assign(nil);

  LIcon := TIconEx.Create;
  try
    LIconSize := 32;
    if RadioGroup1.ItemIndex = 0 then LIconSize := 16;
    if RadioGroup1.ItemIndex = 1 then LIconSize := 24;
    if RadioGroup1.ItemIndex = 2 then LIconSize := 32;
    if RadioGroup1.ItemIndex = 3 then LIconSize := 48;
    if RadioGroup1.ItemIndex = 4 then LIconSize := 64;
    if RadioGroup1.ItemIndex = 5 then LIconSize := 128;
    if RadioGroup1.ItemIndex = 6 then LIconSize := 256;

    //TIconExではサイズの指定が可能
    //そのサイズに最も近いアイコンを取得できる
    //該当サイズがない場合は拡大または縮小画像となる
    LIcon.Width  := LIconSize;
    LIcon.Height := LIconSize;

    LIcon.LoadFromFile(LFileName);

    //取得したアイコンを描画
    Image1.Canvas.Draw(0, 0, LIcon);
  finally
    FreeAndNil(LIcon);
  end;
end;

//=============================================================================
//  Edit1のOnKeyDownイベント処理
//  [Enter]でEdit1のファイルを読み込んで描画
//=============================================================================
procedure TForm1.Edit1KeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
  if Key = VK_RETURN then begin
    SpeedButton1Click(nil);
    Key := 0;
  end;
end;

end.

procedure TForm1.Button1Click(Sender: TObject);
var
  LSrcFileName : string;
  LIconSize    : Integer;
  LhIcon       : HICON;
  LIcon        : TIcon;
begin
  Image1.Picture.Assign(nil);

  LSrcFileName := 'D:\000\24.ico';
  LIconSize    := 256;

  //アイコンを取り出す
  LhIcon := LoadImage(0,
                      PChar(LSrcFileName),
                      IMAGE_ICON,
                      LIconSize,
                      LIconSize,
                      LR_LOADFROMFILE);

  if LhIcon <> 0 then begin
    LIcon := TIcon.Create;
    try
      LIcon.Handle   := LhIcon;
      Image1.Canvas.Draw(0, 0, LIcon);
    finally
      FreeAndNil(LIcon);
    end;
  end;
end;

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Image1: TImage;
    Edit1: TEdit;
    SpeedButton1: TSpeedButton;
    OpenPictureDialog1: TOpenPictureDialog;
    RadioGroup1: TRadioGroup;
    procedure FormCreate(Sender: TObject);
    procedure SpeedButton1Click(Sender: TObject);
    procedure Edit1KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
  private
    { Private 宣言 }
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses
  Kicon;

{$R *.dfm}

//=============================================================================
//  フォーム生成時の処理
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
begin
  Edit1.Text        := '';
  Edit1.AutoSelect  := False;

  RadioGroup1.ItemIndex := 2;
  OpenPictureDialog1.InitialDir := ExpandFileName('..\');
end;

//=============================================================================
//  ダイアログを表示してファイルを選択し,アイコンを描画
//  TKIconを使用する例
//
//  usesにKIcoが必要
//=============================================================================
procedure TForm1.SpeedButton1Click(Sender: TObject);
var
  LFileName   : string;
  LIcon       : TKIcon;
  LIconSize   : Integer;
  LDimenstion : TKIconDimension;
begin
  if Sender is TSpeedButton then begin
    OpenPictureDialog1.OptionsEx  := [];
    OpenPictureDialog1.FileName   := '';
    if not OpenPictureDialog1.Execute then exit;

    Edit1.Text := OpenPictureDialog1.FileName;
    OpenPictureDialog1.InitialDir := ExtractFileDir(Edit1.Text);
  end;
  if Edit1.Text = '' then exit;

  LFileName := Edit1.Text;
  Image1.Picture.Assign(nil);

  LIcon := TKIcon.Create;
  try
    LIconSize := 32;
    if RadioGroup1.ItemIndex = 0 then LIconSize := 16;
    if RadioGroup1.ItemIndex = 1 then LIconSize := 24;
    if RadioGroup1.ItemIndex = 2 then LIconSize := 32;
    if RadioGroup1.ItemIndex = 3 then LIconSize := 48;
    if RadioGroup1.ItemIndex = 4 then LIconSize := 64;
    if RadioGroup1.ItemIndex = 5 then LIconSize := 128;
    if RadioGroup1.ItemIndex = 6 then LIconSize := 256;

    //TIconExではサイズの指定が可能
    //そのサイズに最も近いアイコンを取得できる
    //該当サイズがない場合は拡大または縮小画像となる

    LIcon.LoadFromFile(LFileName);

    if LIcon.IconCount = 1 then begin
      //シングルアイコンの場合はリサイズ描画
      Image1.Canvas.StretchDraw(Rect(0, 0, LIconSize, LIconSize), LIcon);
    end else begin
      //マルチアイコンの場合
      //取得サイズを設定して取得
      //ない場合は大きいサイズを取得することがある
      LIcon.DisplayAll  := False;
      LIcon.OptimalIcon := True;

      LDimenstion.Width   := LIconSize;
      LDimenstion.Height  := LIconSize;
      LIcon.RequestedSize := LDimenstion;

      //取得したアイコンを描画
      Image1.Canvas.Draw(0, 0, LIcon);
    end;
  finally
    FreeAndNil(LIcon);
  end;
end;

//=============================================================================
//  Edit1のOnKeyDownイベント処理
//  [Enter]でEdit1のファイルを読み込んで描画
//=============================================================================
procedure TForm1.Edit1KeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
  if Key = VK_RETURN then begin
    SpeedButton1Click(nil);
    Key := 0;
  end;
end;

end.

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls, Buttons, ExtDlgs, KIcon;

type
  TForm1 = class(TForm)
    Image1: TImage;
    Edit1: TEdit;
    SpeedButton1: TSpeedButton;
    OpenPictureDialog1: TOpenPictureDialog;
    Label1: TLabel;
    SpeedButton2: TSpeedButton;
    procedure FormCreate(Sender: TObject);
    procedure SpeedButton1Click(Sender: TObject);
    procedure Edit1KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
    procedure SpeedButton2Click(Sender: TObject);
  private
    { Private 宣言 }
    FKIcon : TKIcon;
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

//=============================================================================
//  フォーム生成時の処理
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
begin
  Edit1.Text        := '';
  Edit1.AutoSelect  := False;

  OpenPictureDialog1.InitialDir := ExpandFileName('..\..\');

  //TPictureとTKIconを統合
  RegisterKIcon;
end;

//=============================================================================
//  ダイアログを表示してファイルを選択
//  アイコンファイルをTImage.Pictureにロードする
//=============================================================================
procedure TForm1.SpeedButton1Click(Sender: TObject);
var
  LFileName : string;
begin
  if Sender is TSpeedButton then begin
    OpenPictureDialog1.OptionsEx  := [];
    OpenPictureDialog1.FileName   := '';
    if not OpenPictureDialog1.Execute then exit;

    Edit1.Text := OpenPictureDialog1.FileName;
    OpenPictureDialog1.InitialDir := ExtractFileDir(Edit1.Text);
    LFileName := OpenPictureDialog1.FileName;
  end else begin
    if Edit1.Text = '' then exit;
    LFileName := Edit1.Text;
  end;

  //TImage.Picture.GraphicをTKIconとする
  //TKIcon.Createは不要．解放処理も不要
  Image1.Picture.LoadFromFile(LFileName);
  FKIcon := TKIcon(Image1.Picture.Graphic);
  FKIcon.DisplayAll := False;

  Edit1.Text     := Edit1.Text;
  Label1.Caption := 'アイコン数 : ' + IntToStr(FKIcon.IconCount);
end;

{$WRITEABLECONST ON}

//=============================================================================
//  アイコンのインデックスを変更してそのアイコンを表示
//=============================================================================
procedure TForm1.SpeedButton2Click(Sender: TObject);
const
  LIconIndex : Integer = -1;
begin
  if not Assigned(FKIcon) then exit;

  //OptimalIconをFlaseにする
  FKIcon.OptimalIcon := False;

  inc(LIconIndex);
  if LIconIndex >= FKIcon.IconCount then begin
    LIconIndex := 0;
  end;
  //インデックスを変更すると自動でTImageにそのインデックスのアイコンを表示する
  FKIcon.CurrentIndex := LIconIndex;
end;

{$WRITEABLECONST OFF}

//=============================================================================
//  Edit1のOnKeyDownイベント処理
//  [Enter]でEdit1のファイルを読み込んで描画
//=============================================================================
procedure TForm1.Edit1KeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
  if Key = VK_RETURN then begin
    SpeedButton1Click(nil);
    Key := 0;
  end;
end;

end.

  //現在のインデックスのアイコンを単独アイコンファイルとして保存する例
  //TNkDIBは24ビットに変換して処理していることに注意
  //アイコンはビットマップとして格納されている．それを取り出して処理
  LKIcon  := TKIcon.Create;
  LBitmap := TBitmap.Create;
  LNkDIB  := TNkDIB.Create;
  try
    FKIcon.CopyToBitmap(LIconIndex, LBitmap);
    LKIconData := FKIcon.IconData[LIconIndex];

    //減色処理
    LNkDIB.Assign(LBitmap);
    if LKIconData.Bpp = 4 then begin
      LNkDIB.PixelFormat := nkPf4Bit;
      LBitmap.Assign(LNkDIB);
    end else
    if LKIconData.Bpp = 8 then begin
      LNkDIB.PixelFormat := nkPf8Bit;
      LBitmap.Assign(LNkDIB);
    end;
    LKIcon.Add(MakeHandles(LBitmap.Handle, LBitmap.MaskHandle));
    //保存
    LKIcon.SaveToFile(IntToStr(LIconIndex) + '.ico');
  finally
    FreeAndNil(LKIcon);
    FreeAndNil(LBitmap);
    FreeAndNil(LNkDIB);
  end;