unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    SpeedButton1: TSpeedButton;
    SpeedButton2: TSpeedButton;
    LabeledEdit1: TLabeledEdit;
    LabeledEdit2: TLabeledEdit;
    Button1: TButton;
    OpenDialog1: TOpenDialog;
    OpenDialog2: TOpenDialog;
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure SpeedButton1Click(Sender: TObject);
    procedure SpeedButton2Click(Sender: TObject);
  private
    { Private 宣言 }
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses
  madRes,
  ShlObj;

{$R *.dfm}

//=============================================================================
//  フォーム生成時の処理
//
//  Program Files内のEXEは管理者権限でないとアイコンの変更はできない
//  システム関係フォルダ内のEXEは管理者権限でも変更できない(アクセス権による)
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
begin
  LabeledEdit1.AutoSelect := False;
  LabeledEdit2.AutoSelect := False;
  ActiveControl := LabeledEdit1;

  LabeledEdit1.Text := ExpandFileName('..\Target.exe');
  LabeledEdit2.Text := ExpandFileName('..\Multi.ico');
end;

//=============================================================================
//  アプリケーションアイコンを変更するEXEファイル名を選択
//=============================================================================
procedure TForm1.SpeedButton1Click(Sender: TObject);
begin
  OpenDialog1.Filter := 'exe ファイル (*.exe)|*.exe';
  if OpenDialog1.Execute then begin
    //.lnkファイルは"(ダブルクォーテーション・引用符)が付いてくることがある
    //それを取り除いておく
    LabeledEdit1.Text := AnsiDequotedStr(PChar(OpenDialog1.FileName), '"');
    OpenDialog1.InitialDir := ExtractFileDir(OpenDialog1.FileName);
  end;
end;

//=============================================================================
//  アプリケーションアイコンとして設定するアイコンファイルを選択
//=============================================================================
procedure TForm1.SpeedButton2Click(Sender: TObject);
begin
  OpenDialog2.Filter := 'アイコンファイル (*.ico)|*.ico';
  if OpenDialog2.Execute then begin
    LabeledEdit2.Text := OpenDialog2.FileName;
    OpenDialog2.InitialDir := ExtractFileDir(OpenDialog2.FileName);
  end;
end;

//=============================================================================
//  EXEのアプリケーションアイコンを変更
//  Delphiで作成したEXEで,リソース言語が日本語の場合
//  madResの関数類を使用したコード
//
//  アイコン変更と同時に現在のEXEのアプリケーションアイコンを保存する
//  保存場所と保存名はコード内で決め打ち
//
//  SHChangeNotifyの使用にはusesにShlObjが必要
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  LExePath      : string;
  LIconPath     : string;
  LResName      : string;
  LLanguage     : Word;
  LResHandle    : DWORD;
  LSaveIconPath : string;
  LNewIconPath  : string;
  LText         : string;
begin
  LExePath  := Trim(LabeledEdit1.Text);
  LIconPath := Trim(LabeledEdit2.Text);

  //LLanguageの値は日本の場合1041
  LResName  := 'MAINICON';
  LLanguage := MAKELANGID(LANG_JAPANESE, SUBLANG_DEFAULT);

  LResHandle := madRes.BeginUpdateResourceW(PChar(LExePath), False);
  if LResHandle = 0 then  begin
    LText := 'アイコンの変更はできませんでした．' ;
    MessageBox(Handle, PChar(LText), '情報', MB_ICONINFORMATION);
  end else begin
    //現在のアイコンをファイルに保存
    //保存名は固定
    LSaveIconPath := ExpandFileName('..\MAINICON.ico');
    if LSaveIconPath = LIconPath then begin
      LNewIconPath := ChangeFileExt(LIconPath, '') + '_01.ico';
      RenameFile(LIconPath, LNewIconPath);
      LIconPath := LNewIconPath;
    end;

    if madRes.SaveIconGroupResourceW(LResHandle,
                                  PChar(LResName),
                                  LLanguage,
                                  PChar(LSaveIconPath)) then begin
      //新しいアイコンを設定する
      madRes.LoadIconGroupResourceW(LResHandle,
                                    PChar(LResName),
                                    LLanguage,
                                    PChar(LIconPath));
      DeleteFile(LNewIconPath);
    end else begin
      //アイコンが保存できない時は,該当するアイコンがない場合なので中止する
      LText := '識別子が MAINICON のリソースが見つかりませんでした．' + sLineBreak
             + 'アイコンの変更を中止します．';
      MessageBox(Handle, PChar(LText), '情報', MB_ICONINFORMATION);
    end;
    madRes.EndUpdateResourceW(LResHandle, False);
    //システムにアイコンの変更を通知
    //EndUpdateResourceWの後に実行すること
    SHChangeNotify(SHCNE_ASSOCCHANGED, SHCNF_FLUSH, nil, nil);
  end;
end;

end.

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    SpeedButton1: TSpeedButton;
    SpeedButton2: TSpeedButton;
    LabeledEdit1: TLabeledEdit;
    LabeledEdit2: TLabeledEdit;
    Button1: TButton;
    OpenDialog1: TOpenDialog;
    OpenDialog2: TOpenDialog;
    Button2: TButton;
    Button3: TButton;
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure SpeedButton1Click(Sender: TObject);
    procedure SpeedButton2Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
  private
    { Private 宣言 }
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses
  madRes,
  ShlObj;

{$R *.dfm}

//-----------------------------------------------------------------------------
//  EnumResourceNamesのコールバック関数
//  RT_GROUP_ICON(icon group)の最初のリソースの識別子(文字列)を取得
//-----------------------------------------------------------------------------
function EnumResNames(hModule: HWND; lpszType: LPCTSTR; lpszName: LPTSTR;
  lParam: PString): LongBool; stdcall;
var
  LResIDStr : string;
begin
  Result := True;

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

  if lParam^ <> '' then Result := False;
end;

//=============================================================================
//  フォーム生成時の処理
//
//  Program Files内のEXEは管理者権限でないとアイコンの変更はできない
//  システム関係フォルダ内のEXEは管理者権限でも変更できない
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
begin
  LabeledEdit1.AutoSelect := False;
  LabeledEdit2.AutoSelect := False;
  ActiveControl := LabeledEdit1;

  LabeledEdit1.Text := ExpandFileName('..\Target.exe');
  LabeledEdit2.Text := ExpandFileName('..\Multi.ico');
end;

//=============================================================================
//  アプリケーションアイコンを変更するEXEファイル名を選択
//=============================================================================
procedure TForm1.SpeedButton1Click(Sender: TObject);
begin
  OpenDialog1.Filter := 'exe ファイル (*.exe)|*.exe';
  if OpenDialog1.Execute then begin
    //.lnkファイルは"(ダブルクォーテーション・引用符)が付いてくることがある
    //それを取り除いておく
    LabeledEdit1.Text := AnsiDequotedStr(PChar(OpenDialog1.FileName), '"');
    OpenDialog1.InitialDir := ExtractFileDir(OpenDialog1.FileName);
  end;
end;

//=============================================================================
//  アプリケーションアイコンとして設定するアイコンファイルを選択
//=============================================================================
procedure TForm1.SpeedButton2Click(Sender: TObject);
begin
  OpenDialog2.Filter := 'アイコンファイル (*.ico)|*.ico';
  if OpenDialog2.Execute then begin
    LabeledEdit2.Text := OpenDialog2.FileName;
    OpenDialog2.InitialDir := ExtractFileDir(OpenDialog2.FileName);
  end;
end;

//=============================================================================
// アプリケーションアイコンを変更
//  実際にはリソースの追加
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  LExePath    : string;
  LIconPath   : string;
  LhModule    : THandle;
  LResIDName  : string;
  LpResIDName : PChar;
  LResIDInt   : Integer;
  LLanguage   : Word;
  LResHandle  : DWORD;
  LText       : string;
begin
  LExePath  := Trim(LabeledEdit1.Text);
  LIconPath := Trim(LabeledEdit2.Text);

  //RT_GROUP_ICON(icon group)の最初のリソースの識別子(文字列)を検索
  LhModule := LoadLibraryEx(PChar(LExePath),
                            0,
                            LOAD_LIBRARY_AS_DATAFILE or
                            LOAD_WITH_ALTERED_SEARCH_PATH);
  if LhModule <> 0 then begin
    EnumResourceNames(LhModule, RT_GROUP_ICON, @EnumResNames, LPARAM(@LResIDName));
    FreeLibrary(LhModule);
  end;
  if LResIDName = '' then begin
    LText := 'アイコンの変更はできませんでした．' ;
    MessageBox(Handle, PChar(LText), '情報', MB_ICONINFORMATION);
    exit;
  end;


  //リソースIDの文字列からリソースIDを作成
  LResIDInt := StrToIntDef(LResIDName, -1);
  if LResIDInt < 0 then begin
    LpResIDName := PChar(LResIDName);
  end else begin
    LpResIDName := PChar(MakeIntResource(IntToStr(LResIDInt)));
  end;

  LLanguage := MAKELANGID(LANG_NEUTRAL, SUBLANG_NEUTRAL);

  //指定リソース識別と言語識別子でアプリケーションアイコンのリソースを追加
  LResHandle := madRes.BeginUpdateResourceW(PChar(LExePath), False);
  if LResHandle = 0 then begin
    LText := 'アイコンの変更はできませんでした．' ;
    MessageBox(Handle, PChar(LText), '情報', MB_ICONINFORMATION);
  end else begin
    madRes.LoadIconGroupResourceW(LResHandle,
                                  LpResIDName,
                                  LLanguage,
                                  PChar(LIconPath));
    madRes.EndUpdateResourceW(LResHandle, False);

    //システムにアイコンの変更を通知
    //EndUpdateResourceWの後に実行しないと無効
    Button3Click(nil);
  end;
end;

//=============================================================================
// アプリケーションアイコンを元に戻す
//  実際には追加したリソースの削除
//  最初のリソース識別子の言語識別子が0のリソースを削除する
//  ない場合は削除しない
//=============================================================================
procedure TForm1.Button2Click(Sender: TObject);
var
  LExePath    : string;
  LhModule    : THandle;
  LLanguage   : Word;
  LResHandle  : DWORD;
  LResIDName  : string;
  LpResIDName : PChar;
  LResIDInt   : Integer;
begin
  //.lnkファイルをTOpenDialogで選択する"(ダブルクォーテーション・引用符)が付いて
  //くることがある．それを取り除く
  LExePath  := AnsiDequotedStr(PChar(LabeledEdit1.Text), '"');

  //RT_GROUP_ICON(icon group)の最初のリソース識別子(文字列)を検索
  LhModule := LoadLibraryEx(PChar(LExePath),
                            0,
                            LOAD_LIBRARY_AS_DATAFILE or
                            LOAD_WITH_ALTERED_SEARCH_PATH);
  if LhModule <> 0 then begin
    EnumResourceNames(LhModule, RT_GROUP_ICON, @EnumResNames, LPARAM(@LResIDName));
    FreeLibrary(LhModule);
  end;
  if LResIDName = '' then exit;

  //リソースIDの文字列からリソースIDを作成
  LResIDInt := StrToIntDef(LResIDName, -1);
  if LResIDInt < 0 then begin
    LpResIDName := PChar(LResIDName);
  end else begin
    LpResIDName := PChar(MakeIntResource(IntToStr(LResIDInt)));
  end;


  //言語識別子がこの値のアイコンリソースを削除する
  //ない場合は削除しない
  LLanguage := MAKELANGID(LANG_NEUTRAL, SUBLANG_NEUTRAL);

  //追加したアプリケーションアイコンのリソースを削除
  LResHandle := madRes.BeginUpdateResourceW(PChar(LExePath), False);
  if LResHandle <> 0 then begin
    madRes.DeleteIconGroupResourceW(LResHandle, LpResIDName, LLanguage);
    madRes.EndUpdateResourceW(LResHandle, False);

    //システムにアイコンの変更を通知
    //EndUpdateResourceWの後に実行しないと無効
    Button3Click(nil);
  end;
end;

//=============================================================================
//  システムにアイコンの変更を通知
//=============================================================================
procedure TForm1.Button3Click(Sender: TObject);
begin
  SHChangeNotify(SHCNE_ASSOCCHANGED, SHCNF_FLUSH, nil, nil);
end;

end.

program Project1;

uses
  Forms,
  SysUtils,
  Unit1 in 'Unit1.pas' {Form1};

{$R *.res}

begin
  Application.Initialize;
  Application.Icon.LoadFromFile(ExpandFileName('..\Multi.ico'));
  Application.MainFormOnTaskbar := True;
  Application.CreateForm(TForm1, Form1);
  Application.Run;
end.

procedure TForm1.FormCreate(Sender: TObject);
begin
  Application.Icon.LoadFromFile(ExpandFileName('..\Multi.ico'));
end;

  SHChangeNotify(SHCNE_UPDATEDIR, SHCNF_PATH, PChar(DirPath), nil);

uses
  ShlObj,
  ShellAPI;

{$R *.dfm}

//=============================================================================
//  拡張子の関連付けを変更してもファイルのアイコン画像が変更されない場合の処理
//  エクスプローラのアイコン表示が更新されない場合も利用可能
//  [F5] ([表示][最新の情報に更新] を実行して関連付けの変更を通知
//
//  SHChangeNotifyの使用にはusesにShlObjが必要
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
begin
  SendMessage(HWND_BROADCAST, WM_COMMAND, 28931, 0);
  //実際には以下だけでよい
  SHChangeNotify(SHCNE_ASSOCCHANGED, SHCNF_IDLIST, nil, nil);
end;

//=============================================================================
//  エクスプローラの表示アイコンを更新する例
//  ie4uinit.exeを使用
//  ie4uinit.exeはIE,エクスプローラの初期化用ユーティリティ
//  64ビットのWindowsには64ビットのie4uinit.exeしかない
//
//  このコードは64ビットのWindowsで32ビットのEXEから実行する例
//  Windows10では-ClearIconCacheの代わりに-showを指定する
//=============================================================================
procedure TForm1.Button2Click(Sender: TObject);
var
  LCmdExe   : string;
  LCmdParam : string;
begin
  LCmdExe   := 'C:\windows\Sysnative\ie4uinit.exe';
  LCmdParam := '-ClearIconCache';
  ShellExecute(Handle, '', PChar(LCmdExe), PChar(LCmdParam), nil, SW_HIDE);
end;