(*----------------------------------------
アイコン処理用ユニット
2012/09/05(水)
・	作成
	GetFileIcon/GetFileExtIcon/GetFolderIcon
2012/10/31(水)
・	ImageList_SetFileIconを実装
//----------------------------------------*)

unit IconUnit;

interface

uses
  Windows,      //FILE_ATTRIBUTE_NORMAL
  CommCtrl,     //ImageList_GetIcon
  Controls,     //TImageList
  Graphics,     //TIcon
  ShellAPI,     //TSHFileInfo
  SysUtils,     //FileExists

  Classes,

  StringUnit,
  NameValueUnit,
end_uses;

type
  TIconSize = (isLarge, isSmall);

function GetFileIcon(FileName: String; IconSize: TIconSize): HICON;
function GetFileExtIcon(ExtName: String; IconSize: TIconSize): HICON;
function GetFolderIcon(IconSize: TIconSize): HICON;
procedure ImageList_SetIcon(ImageList: TImageList; IconHandle: HICON);
procedure ImageList_SetIconKeyIndex(ImageList: TImageList; KeyList: TStringList;
 IconHandle: HICON; Key: String);
procedure ImageList_SetFileIcon(ImageList: TImageList; KeyList: TStringList;
 KeyPath: String; IconSize: TIconSize);
function GetImageListIndex(KeyList: TStringList; Key: String): Integer;


implementation

////////////////////////////////////////////////////////////
//フルパスファイル名からアイコンを取得

function GetFileIcon(FileName: String; IconSize: TIconSize): HICON;
var
  SHFInfo: TSHFileInfo;
  Flag: Integer;
begin
  case IconSize of
    isLarge: Flag := SHGFI_LARGEICON;
    isSmall: Flag := SHGFI_SMALLICON
  end;

  SHGetFileInfo(PChar(FileName),
                0,
                SHFInfo,
                SizeOf(SHFInfo),
                SHGFI_ICON or
                Flag or
                SHGFI_DISPLAYNAME);
  Result := SHFInfo.hIcon;
end;

////////////////////////////////////////////////////////////
//拡張子からアイコンを取得
{ExtNameは'.html'の形式で指定する}
function GetFileExtIcon(ExtName: String; IconSize: TIconSize): HICON;
var
  FileName: String;
  SHFInfo: TSHFileInfo;
  Flag: Integer;
begin
  case IconSize of
    isLarge: Flag := SHGFI_LARGEICON;
    isSmall: Flag := SHGFI_SMALLICON
  end;

  SHGetFileInfo(PChar(IncludeFirstStr(ExtName, '.*')),
                FILE_ATTRIBUTE_NORMAL,
                SHFInfo,
                SizeOf(SHFInfo),
                SHGFI_ICON or
                Flag or
                SHGFI_USEFILEATTRIBUTES);
  Result := SHFInfo.hIcon;
end;
{関連づいていないIconは関連づいていないIconが返されるので
 エクスプローラの表示と同じ物が取得できる。}

 ////////////////////////////////////////////////////////////
//フォルダアイコンを取得する方法
function GetFolderIcon(IconSize: TIconSize): HICON;
var sfi: TSHFileInfo;
    hi: THandle;
  Flag: Integer;
begin
  case IconSize of
    isLarge: Flag := SHGFI_LARGEICON;
    isSmall: Flag := SHGFI_SMALLICON
  end;

  hi := SHGetFileInfo('',
          FILE_ATTRIBUTE_DIRECTORY,
          sfi, SizeOf(sfi),
          SHGFI_LARGEICON or
          SHGFI_SYSICONINDEX or
          SHGFI_USEFILEATTRIBUTES);
  Result := ImageList_GetIcon(hi, sfi.iIcon, 0);
end;
{参考：[Delphi:50979] Re: フォルダアイコンの取得}

////////////////////////////////////////////////////////////
//使いやすいようにImageListに代入する手続き
procedure ImageList_SetIcon(ImageList: TImageList; IconHandle: HICON);
var
  Icon1: TIcon;
begin
  Icon1 := TIcon.Create;
  try
    Icon1.Handle := IconHandle;

    ImageList.AddIcon(Icon1);

    Icon1.ReleaseHandle;
  finally
    Icon1.Free;
  end;
end;

procedure ImageList_SetIconKeyIndex(ImageList: TImageList; KeyList: TStringList;
 IconHandle: HICON; Key: String);
var
  Icon1: TIcon;
begin
  ImageList_SetIcon(ImageList, IconHandle);
  KeyList.Values[Key] := IntToStr(ImageList.Count - 1);
end;

procedure ImageList_SetFileIcon(ImageList: TImageList; KeyList: TStringList;
 KeyPath: String; IconSize: TIconSize);
begin
  if KeyList.IndexOfName(KeyPath) = -1 then
  begin
    ImageList_SetIconKeyIndex(ImageList, KeyList,
      GetFileIcon(KeyPath, IconSize), KeyPath);
  end;
end;

function GetImageListIndex(KeyList: TStringList; Key: String): Integer;
begin
  Result := StrToInt( KeyList.Values[Key] );
end;
////////////////////////////////////////////////////////////

end.