“アイコンの変更”ダイアログ (ID:9954)

名前

ホームページ(ブログ、Twitterなど)のURL (省略可)

本文

WinNT 系でも Win9X 系でも動作するようにしました。

uses ShellAPI;

function PickIconDialogW(Handle:THandle; FileName:PWideChar;var FileNameSize:DWORD;
       var IconIndex:DWORD):Boolean; stdcall; external 'shell32.dll' index 62;

function PickIconDialogA(Handle:THandle; FileName:PChar;var FileNameSize:DWORD;
       var IconIndex:DWORD):Boolean; stdcall; external 'shell32.dll' index 62;

function PickIconDlgW(Filename:string):HICON;
var
  Size,Index:DWORD;
  InitFile:WideString;
  targetFile:string;
  wBuf:PWideChar;
begin
  result := THandle(-1);

GetMem(wBuf,MAX_PATH*2+2);
  ZeroMemory(wBuf,MAX_PATH*2+2);
  Size := MAX_PATH;
  InitFile := Filename;
  CopyMemory(wBuf,PWideChar(InitFile),Length(InitFile)*2);

if PickIconDialogW(0,wBuf,Size,Index) then
  begin
    TargetFile := WideString(wBuf);
    result := ExtractIcon(hInstance,PChar(TargetFile),Index);
  end;

FreeMem(wBuf);
end;

function PickIconDlgA(Filename:string):HICON;
var
  Size,Index:DWORD;
  targetFile:string;
  Buf:PChar;
begin
  result := THandle(-1);

GetMem(Buf,MAX_PATH+1);
  ZeroMemory(Buf,MAX_PATH+1);
  Size := MAX_PATH;
  CopyMemory(Buf,PChar(Filename),Length(Filename));

if PickIconDialogA(0,Buf,Size,Index) then
  begin
    TargetFile := string(Buf);
    result := ExtractIcon(hInstance,PChar(TargetFile),Index);
  end;

FreeMem(Buf);
end;

// 初期ファイルを指定して実行

procedure TForm1.Button1Click(Sender: TObject);
var
  hIcn:HICON;
  Icon:TIcon;
begin
  if OpenDialog1.Execute then
  begin
    if Win32Platform = VER_PLATFORM_WIN32_NT then
      hIcn := PickIconDlgW(OpenDialog1.Filename)
    else
      hIcn := PickIconDlgA(OpenDialog1.Filename);

if hIcn > 0 then begin
      Icon := TIcon.Create;
      try
        Icon.Handle := hIcn;
        self.Refresh;
        self.Canvas.Draw(10,10,Icon);
      finally
        Icon.Free;
      end;
    end;
  end;
end;

// 初期ファイルを指定しないで実行 （Shell32.dllから）

procedure TForm1.Button2Click(Sender: TObject);
var
  hIcn:HICON;
  Icon:TIcon;
begin
  if Win32Platform = VER_PLATFORM_WIN32_NT then
    hIcn := PickIconDlgW('')
  else
    hIcn := PickIconDlgA('');

if hIcn > 0 then begin
    Icon := TIcon.Create;
    try
      Icon.Handle := hIcn;
      self.Refresh;
      self.Canvas.Draw(10,10,Icon);
    finally
      Icon.Free;
    end;
  end;
end;

←解決時は質問者本人がここをチェックしてください。

戻る