Модераторы: Snowy, MetalFan, bems, Poseidon
  

Поиск:

Ответ в темуСоздание новой темы Создание опроса
> Получение иконок, иконка моего компьютера 
:(
    Опции темы
RMiB
Дата 18.5.2009, 22:30 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Новичок



Профиль
Группа: Участник
Сообщений: 2
Регистрация: 24.4.2008

Репутация: нет
Всего: нет
В программе нужно получить иконку Мой компьютер и вывести её в Image, нашёл, что для нахождения иконки можно использовать SHGetFileInfo(LPCTSTR pszPath,...) у которого(справка по win32):
If uFlags includes the SHGFI_PIDL, value pszPath must be the address of an ITEMIDLIST structure that contains the list of item identifiers that uniquely identifies the file within the shell's name space. 
вот код:

Код

procedure TForm1.FormCreate(Sender: TObject);
var ImageHandle:thandle;
    info:SHFILEINFO;
begin  
  ImageHandle:= SHGetFileInfo('',0,info,sizeof(info),SHGFI_PIDL);
  if (ImageHandle <> 0) then
  begin
    ImageList1.Handle:= ImageHandle;
    ImageList1.ShareImages:= true;
  end;

end;

procedure TForm1.BitBtn1Click(Sender: TObject);
var info:shfileinfo;
    result:integer;
    PIDL:PItemIDList;
begin
  SHGetSpecialFolderLocation( Handle, CSIDL_DRIVES, PIDL );
  result:= SHGetFileInfo(pointer(PIDL),0,info,sizeof(info),SHGFI_PIDL);
   if(result <> 0) then
    ImageList1.GetIcon(info.iIcon,Image1.Picture.Icon);
end;

как поправить чтоб оно работало??, или возможно есть другой способ получения иконки Моего компьютера???
PM MAIL   Вверх
Keeper89
Дата 18.5.2009, 23:03 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Эксперт
****


Профиль
Группа: Завсегдатай
Сообщений: 2580
Регистрация: 26.2.2009

Репутация: 9
Всего: 58
Код

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ShellAPI, ActiveX, ShlObj, ComObj, StdCtrls, ImgList, CommCtrl,
  ExtCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Image1: TImage;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

  TIconType = (itSmall, itLarge);

var
  Form1: TForm1;

implementation

{$R *.dfm}

function GetIcon(PIDL: PItemIDList;
                 IconType: TIconType = itSmall): TIcon;
const
  SFGAO_SHARE = $20000;
  Flags: array[TIconType] of DWORD = (SHGFI_SMALLICON, SHGFI_LARGEICON);
var
  FileInfo: TSHFileInfo;
  Ico: TIcon;
  ListHandle: HIMAGELIST;
begin
  Ico := TIcon.Create;
  Result := Nil;
  with Ico do
  begin
    FillChar(FileInfo, Sizeof(FileInfo), #0);
    ListHandle := SHGetFileInfo(Pointer(PIDL), SFGAO_SHARE, FileInfo,
                                SizeOf(FileInfo),
                                Flags[IconType] or
                                SHGFI_SYSICONINDEX or
                                SHGFI_PIDL);
    if ListHandle <> 0 then
    begin
      Handle := ImageList_GetIcon(ListHandle, FileInfo.iIcon, ILD_NORMAL);
      Result := Ico;
    end;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  PIDL: PItemIDList;
begin
  SHGetSpecialFolderLocation(Handle, CSIDL_DRIVES, PIDL);
  Image1.Picture.Icon := GetIcon(PIDL);
end;

end.


Это сообщение отредактировал(а) Keeper89 - 18.5.2009, 23:18


--------------------
Cogito, ergo sum

Keeper's blog
CnWizards Downloads

user posted image
PM MAIL WWW   Вверх
Rrader
  Дата 19.5.2009, 06:49 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Inspired =)
***


Профиль
Группа: Экс. модератор
Сообщений: 1535
Регистрация: 7.5.2005

Репутация: 18
Всего: 191
Keeper89,

1) PIDL надо освобождать.
2)
Код

CoInitialize(nil);

3)Функцию лучше переделать в процедуру, а результат в виде объекта реализовать как параметр.


--------------------
Let's do this quickly!
Rest in peace, Vit!
PM MAIL Skype   Вверх
Keeper89
Дата 19.5.2009, 16:11 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Эксперт
****


Профиль
Группа: Завсегдатай
Сообщений: 2580
Регистрация: 26.2.2009

Репутация: 9
Всего: 58
Rrader, первые 2 исправил.
Код

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ShellAPI, ActiveX, ShlObj, ComObj, StdCtrls, ImgList, CommCtrl,
  ExtCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Image1: TImage;
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

  TIconType = (itSmall, itLarge);

var
  Form1: TForm1;

implementation

{$R *.dfm}

function GetIcon(PIDL: PItemIDList;
                 IconType: TIconType = itSmall): TIcon;
const
  SFGAO_SHARE = $20000;
  Flags: array[TIconType] of DWORD = (SHGFI_SMALLICON, SHGFI_LARGEICON);
var
  FileInfo: TSHFileInfo;
  Ico: TIcon;
  ListHandle: HIMAGELIST;
begin
  Ico := TIcon.Create;
  Result := Nil;
  with Ico do
  begin
    FillChar(FileInfo, Sizeof(FileInfo), #0);
    ListHandle := SHGetFileInfo(Pointer(PIDL), SFGAO_SHARE, FileInfo,
                                SizeOf(FileInfo),
                                Flags[IconType] or
                                SHGFI_SYSICONINDEX or
                                SHGFI_PIDL);
    if ListHandle <> 0 then
    begin
      Handle := ImageList_GetIcon(ListHandle, FileInfo.iIcon, ILD_NORMAL);
      Result := Ico;
    end;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  PIDL: PItemIDList;
begin
  SHGetSpecialFolderLocation(Handle, CSIDL_DRIVES, PIDL);
  Image1.Picture.Icon := GetIcon(PIDL);
  CoTaskMemFree(PIDL);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  CoInitialize(nil);
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  OleUnInitialize;
end;

end.

А переделывать в процедуру зачем?

Это сообщение отредактировал(а) Keeper89 - 19.5.2009, 16:12


--------------------
Cogito, ergo sum

Keeper's blog
CnWizards Downloads

user posted image
PM MAIL WWW   Вверх
Rrader
  Дата 20.5.2009, 14:51 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Inspired =)
***


Профиль
Группа: Экс. модератор
Сообщений: 1535
Регистрация: 7.5.2005

Репутация: 18
Всего: 191
Цитата(Keeper89 @  19.5.2009,  22:11 Найти цитируемый пост)
А переделывать в процедуру зачем?

Для упрощения кода, для облегчения его восприятия. У тебя сейчас функция забирает память - с каждым входом новый объект. А зачем так делать? У Image уже есть в распоряжении Picture.Icon. Плюс желательно сделать проверочку на успешность SHGetSpecialFolderLocation.
Код

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ActiveX, ShlObj, ShellAPI, CommCtrl, ExtCtrls, StdCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Image1: TImage;
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
const
  SFGAO_SHARE = $20000;
var
  FileInfo: TSHFileInfo;
  ListHandle: HIMAGELIST;
  ID: PItemIDList;
begin
  with Image1 do
  begin
    if Succeeded(SHGetSpecialFolderLocation(Handle, CSIDL_DRIVES, ID)) then
    try
      FillChar(FileInfo, SizeOf(FileInfo), 0);
      ListHandle := SHGetFileInfo(Pointer(ID), SFGAO_SHARE, FileInfo,
        SizeOf(FileInfo), SHGFI_LARGEICON or  SHGFI_SYSICONINDEX
        or SHGFI_PIDL);
      if ListHandle <> 0 then
      begin
        Width := GetSystemMetrics(SM_CXICON);
        Height := GetSystemMetrics(SM_CYICON);
        Picture.Icon.Handle := ImageList_GetIcon(ListHandle,
          FileInfo.iIcon, ILD_NORMAL);
      end;
    finally
      CoTaskMemFree(ID);
    end;
  end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  if not Succeeded(CoInitialize(nil)) then
  begin
    ShowMessage('Unable to initialize COM library!');
    Application.Terminate;
  end;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  CoUnInitialize;
end;

end.


Это сообщение отредактировал(а) Rrader - 20.5.2009, 14:52


--------------------
Let's do this quickly!
Rest in peace, Vit!
PM MAIL Skype   Вверх
  
 Ответ в темуСоздание новой темы Создание опроса
Правила форума "Delphi: Для новичков"
SnowyMetalFan
bemsPoseidon
Rrader

Запрещается!

1. Публиковать ссылки на вскрытые компоненты

2. Обсуждать взлом компонентов и делиться вскрытыми компонентами

  • Литературу по Дельфи обсуждаем здесь
  • Действия модераторов можно обсудить здесь
  • С просьбами о написании курсовой, реферата и т.п. обращаться сюда
  • Вопросы по реализации алгоритмов рассматриваются здесь
  • 90% ответов на свои вопросы можно найти в DRKB (Delphi Russian Knowledge Base) - крупнейшем в рунете сборнике материалов по Дельфи

Если Вам понравилась атмосфера форума, заходите к нам чаще! С уважением, Snowy, MetalFan, bems, Poseidon, Rrader.
 
1 Пользователей читают эту тему (1 Гостей и 0 Скрытых Пользователей)
0 Пользователей:
« Предыдущая тема | Delphi: Для новичков | Следующая тема »

Подписаться на тему | Подписка на этот форум | Скачать/Распечатать тему


 




[ Время генерации скрипта: 0.0488 ]   [ Использовано запросов: 21 ]   [ GZIP включён ]


Реклама на сайте     Информационное спонсорство

 
 По вопросам размещения рекламы пишите на vladimir(sobaka)vingrad.ru
Отказ от ответственности     Powered by Invision Power Board(R) 1.3 © 2003  IPS, Inc.