Delphi Tips & Tricks

uses ShellAPI;
//EnumResNameProcのResStr:PCharリソースネームのタイプ
//上位ワードが 0 ならID
//それ以外は文字列へのポインタ
type
  TResNameTypes =(TypeID,TypeName);

//リソースの名前と取得するインデックスを格納して
//コールバック関数に渡すレコード
type
  TIconData =record
    ResNameType :TResNameTypes; //ResStrの種類(ID or 文字列へのポインタ)
    ResID       :PChar;         //IDの場合ここに格納
    ResName     :string;        //文字列の場合ここに格納
    Nowindex    :Cardinal;      //現在の実行モジュール内のアイコンのインデックス
    GetIndex    :Cardinal;      //取得するアイコンのインデックス
end;    
    PIconData =^TIconData;

//EnumResourceNamesのコールバック関数
function EnumResNameProc(hFile :hModule;ResType:PChar;
                         ResStr:PChar; IconData :PIconData):LongBool; stdcall;
begin
  //現在のインデックスが取得するインデックスの場合、参照渡しのTIconDataに情報を格納
  if IconData^.Nowindex =IconData^.Getindex then begin
    //上位ワードが 0 の場合ID
    if HiWord(Cardinal(ResStr)) =0 then begin
      IconData^.ResNameType :=TypeID;
      IconData^.ResID :=ResStr;
    end
    //それ以外は文字列へのポインタ
    else begin
      IconData^.ResNameType :=TypeName;
      IconData^.ResName :=ResStr;
    end;
   
    //列挙を終了
    Result :=False;
  end
  //取得するインデックスでない場合、次に送る
  else begin
     Inc(IconData^.Nowindex);
     Result :=True;
  end;
end;

//リソースID or Nameからアイコンリソースを探してアイコンハンドルを作成し返す
function ResourceToIconHandle(hFile :hModule;IDname :PChar):HICON;
var
  hGicon1,hGicon2,
  hLoadIcon1,hloadIcon2 :THandle;
  pGIcon1,pGicon2 :Pointer;
  IconID :integer;
begin
  Result :=0;
   //リソースをモジュールから探す
   hGicon1 :=FindResource(hFile, IDName, RT_GROUP_ICON);
   if hGicon1 <>0 then
   begin
     //リソースをロード
     hLoadIcon1 :=LoadResource(hFile, hGicon1);
     if hloadicon1 <>0 then
     begin
       //メモリ上の位置を固定しアドレスを取得
       pGicon1 :=LockResource(hLoadIcon1);
       if pGicon1 <>nil then
       begin 
         //リソースの位置から希望サイズのアイコンのIDを取得
         IconID :=LookUpIconIDfromDirectoryEX(pGicon1,true,48,48,LR_DEFAULTCOLOR);
         
     if IconID <>0 then
     begin
       hGicon2    :=FindResource(hFile, MakeIntResource(IconID), RT_ICON);
       hLoadIcon2 :=LoadResource(hFile,hGicon2);
       pGicon2    :=LockResource(hLoadIcon2);
     
     //リソースの位置サイズからアイコンを作成
     Result :=CreateIconfromResourceEx(pGicon2,
                            SizeofResource(hFile,hGicon2),
                            true,
                            $00030000,
                            48, 48,
                            LR_DEFAULTCOLOR);
         end;
       end;
     end;
   end;
end;

//ファイル名から希望のインデックスのリソース名を取得し
//上のResourceToIconHandle関数でアイコンハンドルを取得
function FileNametoResourse(FileName :string; Index :Cardinal):HICON;
var
  hFile    :THandle;
  IconData :TIconData;
begin
  Result :=0;
  //メモリ空間にロード
  hFile :=LoadLibraryEx(PChar(Filename),0,
                        LOAD_LIBRARY_AS_DATAFILE or
                        LOAD_WITH_ALTERED_SEARCH_PATH);

  if hFile <>0 then
  begin
    IconData.Nowindex :=0;
    IconData.GetIndex :=index;
    //取得したいインデックスのリソース情報を取得
    EnumResourceNames(hFile,RT_GROUP_ICON,@EnumResNameProc,LPARAM(@IconData));
   
    //リソースネームがIDか文字列かで、渡すパラメータをかえる
    case Icondata.ResNameType of
      TypeID  :Result :=ResourceToIconHandle(hFile,IconData.ResID);         //ID
      TypeName:Result :=ResourceToIconHandle(hFile,PChar(IconData.ResName));//文字列
    end;
   end;
    //解放
    Freelibrary(hFile);
end;

//アイコンファイルの場合はTIconで簡単に取得
function IcoHandleFromTIcon(FileName :string):HICON;
var
  Ico :TIcon;
begin
  Ico := TIcon.Create;
    try
      Width  :=48;
      Height :=48;
      LoadFromFile(FileName);
      Result :=CopyIcon(Handle);
    finally Free;
    end;
end;

function ExtractIcon48(FileName :string; Index :Cardinal):HICON;
var
  Ext :string;
begin
  Result :=0;
  Ext :=LowerCase(ExtractFileExt(FileName));
  //.exe .dll .cpl でアイコンファイルあり
  if ((Ext='.exe') or (Ext='.dll') or (Ext='.cpl')) and
     (ExtractIcon(hInstance,PChar(Filename),UINT(-1)) >0) then
      Result :=FileNametoResourse(FileName,Index)

   //アイコンファイルの場合 TIconで取得
   else if Ext='.ico' then
     Result :=IcoHandleFromTIcon(Filename);
   
   //指定したファイル名がディレクトリまたは実行モジュール以外では
   //この関数は失敗します
   //取得したい場合は拡張子ごとにレジストリから読み込みます
end;

//実装したExtractIcon48関数の動作確認
//パラメータはファイル名と取得するインデックスを指定
procedure TForm1.Button1Click(Sender: TObject);
var
  HIco :HICON;
begin
  if OpenDialog1.Execute then
  begin 
    Hico :=ExtractIcon48(OpenDialog1.FileName, 0);
    DrawIconEx(Canvas.Handle, 50, 50, Hico, 48, 48, 0, 0, DI_NORMAL);
    DestroyIcon(Hico);
  end;
end;