получить иконку по расширению файла

sanich
Дата: 25.11.2007 11:15:54
нужно будет в listview выводить иконки соостветсвующие расширениям.
Файлы хранятся в базе, расширения вытягиваются от туда

вот что нарыл, но почему то не все иконки выдираются из реестра
например html, htm в реестре не находит.

function GetRegistryIconHandle(FileName: string): HICON;
var
  R: TRegistry;
  Alias, //псевдвним для расширения в реестре
  IconPath: string; //путь для файла с иконкой
  IconNum, //номер иконки в файле
  QPos: Integer; //позиция запятой в записи реестра
begin
  IconNum := 0;

  R := TRegistry.Create;

  try
    R.RootKey := HKEY_CLASSES_ROOT;

    //чтение псевданима
    if R.OpenKey('\' + ExtractFileExt(FileName), True) then
      Alias := R.ReadString('');
    R.CloseKey;

    //чтение записи об иконке
    if R.OpenKey('\' + Alias + '\DefaultIcon', True) then
      IconPath := R.ReadString('');
    R.CloseKey;

    //поиск запятой
    QPos := Pos(',', IconPath);

    //чтение номера иконки в файле если она имеется
    if QPos <> 0 then
    begin
      IconNum := StrToInt(Copy(IconPath, QPos + 1, 4));
      IconPath := Copy(IconPath, 1, QPos - 1)
    end;

  finally
    R.Free;
  end;

  //передача хендлера иконки как рещультат выполнения
  Result := ExtractIcon(hInstance, PChar(IconPath), IconNum);
end;

//============================================================================
procedure TForm1.Button4Click(Sender: TObject);
var Icon: hIcon;
begin
 //icon:=GetRegistryIconHandle('1.jpg');
 repaint;
 icon:=GetRegistryIconHandle(edit1.Text);

 if icon=0  then
  showmessage('нет иконки')
 else begin
  DrawIcon(Canvas.Handle, 10, 10, Icon);
  DestroyIcon(Icon);
 end;
end;

Почему так, может есть более совершенный код?
sanich
Дата: 25.11.2007 12:11:06
ну что никто не знает?
Anatoly Podgoretsky
Дата: 25.11.2007 12:12:50
Время поиска в справке 3 секунды - ExtractAssociatedIcon
sanich
Дата: 25.11.2007 12:33:11
Anatoly Podgoretsky
ExtractAssociatedIcon


Физически расположенный файл ей нужен?
Anatoly Podgoretsky
Дата: 25.11.2007 12:37:57
Нормальные джедаи справку не читают, не царское это дело.

Posted via ActualForum NNTP Server 1.4

sanich
Дата: 25.11.2007 12:43:57
Anatoly Podgoretsky
Нормальные джедаи справку не читают, не царское это дело.
Posted via ActualForum NNTP Server 1.4


Сколько лишних слов вместо одного ответа!
В справке нет описания к этой функции.
Anatoly Podgoretsky
Дата: 25.11.2007 13:11:37
Зато в углу стоит метла.
Warstone
Дата: 25.11.2007 14:36:44
Anatoly Podgoretsky
Зато в углу стоит метла.
Пудель, не флуди.
Автор, Посмотри в Windows SDK, это оттуда.
sanich
Дата: 25.11.2007 15:40:32
Что то не работает эта функция!
procedure TForm1.Button3Click(Sender: TObject);
var
  Icon: hIcon;
  IconIndex: word;
begin
  IconIndex := 1;
  Icon := ExtractAssociatedIcon(HInstance, pchar('c:\1.jpg'), IconIndex);
  DrawIcon(Canvas.Handle, 10, 10, Icon);
end;
1
Дата: 25.11.2007 16:07:40
function GetFileExtAssociatedIcon(const AFileName: string; AIsSmallIcon, AIsLink: Boolean): HIcon;
var
FileInfo: TSHFileInfo;
Flags: Integer;
begin
try
FillChar(FileInfo, SizeOf(TSHFileInfo), 0);
Flags := SHGFI_ICON or SHGFI_USEFILEATTRIBUTES or IfThen(AIsSmallIcon,
SHGFI_SMALLICON) or IfThen(AIsLink, SHGFI_LINKOVERLAY);
SHGetFileInfo(PChar(AFileName), 0, FileInfo, SizeOf(TSHFileInfo), Flags);
Result := FileInfo.hIcon;
except
Result := 0;
end;
end;