Автор: Babay_S
WEB-сайт: http://delphibase.endimus.com

{ **** UBPFD *********** by delphibase.endimus.com ****
>> Вызывает диалог выбора иконки (как при смене значка на десктопе)

Зависимости: uses activex;
Автор:       Babay_S
Copyright:   Мои раскопки
Дата:        27 сентября 2002 г.
***************************************************** }

uses activex;

function ChangeIconDialog(hOwner: LongInt; Filename: string; var IconIndex:
  LongInt): LongInt;
{Вызывает диалог выбора иконки (как при смене значка на десктопе)
Параметры
hOwner - хэндл родителя.
FileName - полный путь файла с иконками (должен существовать).
Если в указанном файле нет иконок, вызываются иконки Shell32.dll.
IconIndex возвращает номер иконки в файле.
Результат выполнения функции возвращает 1 если иконка выбрана и 0 если отмена
Далее эту иконку можно вытащить с помощью вполне документированной функции
ExtractIconEx из той же библиотеки.
}

implementation

function SHChangeIconDialog(hOwner: LongInt; sFilename: LPWSTR; nBuf: LongInt;
  var nIconIndex: LongInt): LongInt;
  stdcall; external 'Shell32.dll' index 62;

function ChangeIconDialog(hOwner: LongInt; Filename: string; var IconIndex:
  LongInt): LongInt;
var
  nFileName: LPWSTR;
  FNLen: Integer;
  i: LongInt;
begin
  FNLen := Length(FileName) + 1;
  nFileName := CoTaskMemAlloc(FnLen * sizeof(WideChar));
  StringToWideChar(FileName, nFileName, FnLen);
  if FileName = '' then
    nFileName := nil;
  Result := SHChangeIconDialog(hOwner, nFileName, 0, IconIndex);
  CoTaskMemFree(nFileName);
end;

Доработанная функция

{ **** UBPFD *********** by delphibase.endimus.com ****
>> Вызывает диалог выбора иконки. Доработанная

Функция вызова диалогового окно "Изменение иконки"

Зависимости: Windows, SysUtils
Автор:       Alex Sal'nikov, alex-co@narod.ru, Москва
Copyright:   Доработка библиотеки JVCL
Дата:        15 июля 2003 г.
***************************************************** }

uses
  Windows, SysUtils;

function ChangeIconDialog(hOwner: tHandle; var FileName: string; var IconIndex:
  Integer): Boolean;
// Функция вызова диалогового окно "Изменение иконки"

implementation

resourcestring
  SNotSupported = 'This function is not supported by your version of Windows';

function ChangeIconDialog(hOwner: tHandle; var FileName: string; var IconIndex:
  Integer): Boolean;
type
  SHChangeIconProc = function(Wnd: HWND; szFileName: PChar; Reserved: Integer;
    var lpIconIndex: Integer): DWORD; stdcall;
  SHChangeIconProcW = function(Wnd: HWND; szFileName: PWideChar;
    Reserved: Integer; var lpIconIndex: Integer): DWORD; stdcall;
const
  Shell32 = 'shell32.dll';
var
  ShellHandle: THandle;
  SHChangeIcon: SHChangeIconProc;
  SHChangeIconW: SHChangeIconProcW;
  Buf: array[0..MAX_PATH] of Char;
  BufW: array[0..MAX_PATH] of WideChar;
begin
  Result := False;
  SHChangeIcon := nil;
  SHChangeIconW := nil;
  ShellHandle := Windows.LoadLibrary(PChar(Shell32));
  try
    if ShellHandle <> 0 then
    begin
      if Win32Platform = VER_PLATFORM_WIN32_NT then
        SHChangeIconW := GetProcAddress(ShellHandle, PChar(62))
      else
        SHChangeIcon := GetProcAddress(ShellHandle, PChar(62));
    end;

    if Assigned(SHChangeIconW) then
    begin
      StringToWideChar(FileName, BufW, SizeOf(BufW));
      Result := SHChangeIconW(hOwner, BufW, SizeOf(BufW), IconIndex) = 1;
      if Result then
        FileName := BufW;
    end
    else if Assigned(SHChangeIcon) then
    begin
      StrPCopy(Buf, FileName);
      Result := SHChangeIcon(hOwner, Buf, SizeOf(Buf), IconIndex) = 1;
      if Result then
        FileName := Buf;
    end
    else
      raise Exception.Create(SNotSupported);
  finally
    if ShellHandle <> 0 then
      FreeLibrary(ShellHandle);
  end;
end;

Пример использования:

procedure TForm1.Button1Click(Sender: TObject);
var
  file: string;
  index: Integer;
begin
  ChangeIconDialog(Handle, file, index);
  Edit1.Text := file;
  Edit2.Text := IntToStr(index);
end;