Вызывает диалог выбора иконки

{codecitation class=»brush: pascal; gutter: false;» width=»600px»}

Автор: 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;

{/codecitation}

Добавить комментарий