View Issue Details

IDProjectCategoryView StatusLast Update
0018247LazarusLCLpublic2021-03-07 16:07
Reporterlainz Assigned Towp  
PrioritynormalSeverityfeatureReproducibilityunable to reproduce
Status assignedResolutionopen 
Platformi386OSWindows 
Product Version0.9.29 (SVN) 
Summary0018247: [Request] TShellListView show Shell System Icons
DescriptionInstead using images to show the file icons in TShellListView use the icons used by the system, in Windows the associated icon to an specific file extension.
TagsListView
Fixed in Revision
LazTarget-
WidgetsetWin32/Win64
Attached Files

Activities

Bart Broersma

2013-07-27 00:32

developer   ~0069126

The ShellTreeView should probably be totally rewritten to be integrated with the underlying WS and OS.

lainz

2015-08-13 13:35

reporter   ~0085331

This seems like impossible and a task for a custom drawn component. Sorry for suggesting this in the past please close it as can't solve.

Felipe Monteiro de Carvalho

2015-08-15 09:01

developer   ~0085363

Maybe its possible, you need to search for an API to get the icon for a given extension ... but its just very low priority to me. Patches are welcome, however.

Janusz Tomczak

2015-08-16 00:26

reporter   ~0085384

http://stackoverflow.com/questions/829843/how-to-get-icon-and-description-from-file-extension-using-delphi

PeterX

2017-11-23 10:01

reporter   ~0104220

http://www.delphipraxis.net/152464-post.html

This is how it works with Delphi ..

Bart Broersma

2017-11-23 15:29

developer   ~0104231

And now for the cross-platform solution ...

Juha Manninen

2021-02-24 18:53

developer   ~0129149

wp, you implemented it for ShellTreeView in r64575, didn't you?

wp

2021-02-24 19:44

developer   ~0129150

Yes, but only for Windows. I had begun with TShellListView as well, essentially what's proposed by PeterX, but this is fairly slow on large folders because the ListView must iterate through all files and determine the icon index. It would be much faster if the ShellListView could be customdrawn to search only for the images of the visible items, similar to the ShellTreeView, but the complexity of custom drawing the ShellListView exceeds my brain, it never produced the result that I intended (it could also be that we are carrying a bug with us in TShellListView custom painting). And still, it would be a Windows-only solution.

Anton Kavalenka

2021-02-24 20:32

reporter   ~0129151

Last edited: 2021-02-24 20:32

View 2 revisions

In attachment - cross-platform engine for icon extraction both for servers and documents.
Works properly for both Windows and Linux, MacOS/X is not implemented
desk.pas (12,353 bytes)   
unit desk;

interface
uses Graphics;

type
  { Shell }

  Shell=class
  class function GetServerPathUTF8(const Doc:utf8string):utf8string;
  class function GetServerPathW(const Doc:widestring):widestring;
  class function GetServerIcon(const path:widestring;gr:TPicture):boolean;
  class function GetSmallDocumentIcon(const path:widestring;gr:TPicture):boolean;
  class function GetMimeTypeUTF8(const path: utf8string):utf8string;
  class function GetMimeTypeW(const path: widestring):widestring;
  class function OpenDocumentW(const path:widestring):widestring;
  class function OpenDocumentUTF8(const path:utf8string):utf8string;
  {$ifdef UNIX}
  class function FindIcon(icon:string; size:integer):string;
  class function FindIconHelper(icon:string; size:integer; theme:string):string;
  class function LookupIcon (const iconname:string; size:integer;const theme:string):string;
  class function LookupFallbackIcon (const iconname:string):string;
  class function DirectoryMatchesSize(const subdir:string; iconsize:integer):boolean;
  {$endif}
  end;

implementation
uses classes,procexec,SysUtils,inifiles,pathtools,lxmlnode,options,strtools
     {$ifdef MSWINDOWS}
     ,windows,shellapi
     {$endif};

class function Shell.GetServerPathW(const Doc:widestring):widestring;
{$IFDEF MSWINDOWS}
var
  bs:ansistring;
  wBuf:array[0..1023] of widechar;
  sbuf:array[0..2047] of ansichar absolute wbuf;
  fMod:THandle;
begin
  Result:='?';
  fMod:=FindExecutableW(PWideChar(Doc),nil,wBuf);
  if fMod>hinstance_error then
    Result:=wBuf
  else
  begin
    bs:=Doc;
    fMod:=FindExecutableA(PAnsiChar(bs),nil,sBuf);
    if fMod>hinstance_error then
      Result:=sBuf
  end;
end;
{$ENDIF}
{$IFDEF UNIX}
begin
  Result:=utf8decode(GetServerPathUTF8(utf8encode(Doc)));
end;
{$ENDIF}

class function Shell.GetServerIcon(const path: widestring; gr: TPicture
  ): boolean;
{$ifdef MSWINDOWS}
type
  PHIcon=^HICON;
var
  cnt,ndx:integer;
  fIcon:HICON;
begin
  Result:=false;
  cnt:=ExtractIconExW(PWideChar(path),-1,PHIcon(nil)^,PHIcon(nil)^,1);
  // no icons in file
  if cnt=0 then exit;
  ndx:=0; // use 1-st icon, extract large icon (1st non-null argument)
  cnt:=ExtractIconExW(PWideChar(path),ndx,fIcon,PHIcon(nil)^,1);
  if cnt>0 then
  begin
    gr.icon.handle:=fIcon;
    Result:=true;
  end;
end;

(*var
  ico:HICON;
begin
  Result:=false;
  Ico:=ExtractIconW(hInstance,PWideChar(path),1);
  if (Ico<>1) and (Ico<>0) then
  begin
    gr.Icon.Handle:=Ico;
    Result:=true;
  end;
end;*)
{$else}
var
  ini:TIniFile;
  sicon:utf8string;
  lst:TwStringList;
begin
  try
    try
      lst:=TwStringList.Create;
      ini:=TMemIniFile.Create('/usr/share/applications/'+path);
      sicon:=ini.ReadString('Desktop Entry','Icon','');
      if sicon<>'' then
      begin
        FileSystem.BuildFileListWithMaskUTF8('/usr/share/icons/hicolor/32x32/apps/'+sicon+'.*',faAnyFile,lst);
        if Lst.Count=0 then
        FileSystem.BuildFileListWithMaskUTF8('/usr/share/icons/hicolor/48x48/apps/'+sicon+'.*',faAnyFile,lst);
        if lst.Count=0 then
        FileSystem.BuildFileListWithMaskUTF8('/usr/share/icons/hicolor/64x64/apps/'+sicon+'.*',faAnyFile,lst);
        if lst.Count>0 then
        begin
          gr.LoadFromFile(lst.uItem[0]);
          Result:=true;
        end;
      end;
    except
    end;
  finally
    ini.Free;
    lst.Free;
  end;
end;
{$endif}

class function Shell.GetServerPathUTF8(const Doc: utf8string): utf8string;
var
  bs:utf8string;
begin
  {$ifdef UNIX}
  bs:=GetMimeTypeUTF8(doc);
  Result:=''; // clear result
  if procexec.CallProcessSelector(
  	'xdg-mime',['query','default',bs],Result) then
  	Result:=Trim(Result)
  else
    Result:='?';

  {$else}
  Result:=utf8encode(GetServerPathW(utf8decode(Doc)));
  {$endif}
end;

class function Shell.GetMimeTypeUTF8(const path: utf8string):utf8string;
var
  bs:utf8string;
  lst:TStrLst;
begin
  Result:='';
  {$ifdef UNIX}
  bs:='';
  {$ifdef LINUX}
  if not procexec.CallProcessSelector(
  	'xdg-mime',['query','filetype',Path],bs) then
    exit;
  Result:=Trim(bs); // mime-type
  {$else}
  if not procexec.CallProcessSelector(
  	'file',['--mime',Path],bs) then
    exit;
  splitresp(bs,';:',lst);
  if length(lst)<2 then exit;
  Result:=Trim(lst[1]);
  {$endif}

  {$else}
  Result:='unimplemented';
  {$endif}
end;

class function Shell.GetMimeTypeW(const path: widestring):widestring;
begin
  Result:=utf8decode(GetMimeTypeUTF8(utf8encode(path)));
end;

class function Shell.OpenDocumentW(const path: widestring): widestring;
{$ifdef MSWINDOWS}var h:Hinst;{$endif}
begin
  Result:='';
  {$ifdef MSWINDOWS}
  h:=ShellExecuteW(GetDesktopWindow(),
                nil,
                PWideChar(path),
                '','',sw_show {na});
  {$else}
   Result:=utf8decode(Shell.OpenDocumentUTF8(utf8encode(path)));
  {$endif}
end;

class function Shell.OpenDocumentUTF8(const path: utf8string): utf8string;
var
  sproc:utf8string;
begin
  Result:='';
  {$ifdef MSWINDOWS}
  {$else}
    {$ifdef DARWIN}
    sproc:='open';
    {$else}
    sproc:='xdg-open';
    {$endif}
    procexec.CallProcessSelector(sproc,[path],Result);
  {$endif}
end;

class function Shell.GetSmallDocumentIcon(const path: widestring; gr: TPicture
  ): boolean;
{$ifdef MSWINDOWS}
type
  PHIcon=^HICON;
var
  wbuf:widestring;
  cnt,ndx:integer;
  fIcon:HICON;
begin
  Result:=false;
  wbuf:=GetServerPathW(path);
  cnt:=ExtractIconExW(PWideChar(wbuf),-1,PHIcon(nil)^,PHIcon(nil)^,1);
  // no icons in file
  if cnt=0 then exit;
  ndx:=1; // use 2-nd icon
  if cnt<2 then ndx:=0;
  cnt:=ExtractIconExW(PWideChar(wbuf),ndx,PHIcon(nil)^,fIcon,1);
  if cnt>0 then
  begin
    gr.icon.handle:=fIcon;
    Result:=true;
    //deleteobject(fLargeIcon);
  end;
end;
{$else}
var
  smime:utf8string;
  xml:TltParser;
  fs:TFileStream;
  sicon:utf8string;
  lst:TwStringList;
  nd:TltNode;
begin
  Result:=false;

  smime:=GetMimeTypeUTF8(utf8encode(path));
  try
    try
      fs:=TFileStream.Create('/usr/share/mime/'+smime+'.xml',fmOpenRead);
    except
      exit;
    end;
    lst:=TwStringList.Create;
    xml:=TltParser.Create();
    xml.Parse(fs);
    nd:=xml.Root.Find('icon');
    if not Assigned(nd) then
    nd:=xml.Root.Find('generic-icon');
    if Assigned(nd) then
      sicon:=options.GetValueByName(nd.Attr,'name',1,'')
    else
    begin
      // mime-type description has no icon,
      // the file is image itself like "image/jpeg"
      try
        gr.LoadFromFile(path);
        if not gr.Graphic.Empty then
        begin
      	  gr.Bitmap.SetSize(16,16);
          Result:=true;
          exit;
        end;
      except
      end;
      // try to resolve generic type
      sicon:=StringReplace(smime,'/','-',[rfReplaceAll]);
    end;

    if sicon<>'' then
    begin
      FileSystem.BuildFileListWithMaskUTF8('/usr/share/icons/Adwaita/16x16/mimetypes/'+sicon+'.*',faAnyFile,lst);
      if Lst.Count=0 then
      FileSystem.BuildFileListWithMaskUTF8('/usr/share/icons/Adwaita/32x32/mimetypes/'+sicon+'.*',faAnyFile,lst);
      if lst.Count>0 then
      begin
        gr.LoadFromFile(lst.uItem[0]);
        Result:=true;
      end;
    end;
  finally
    xml.free;
    fs.Free;
    lst.Free;
  end;


end;
{$endif}

{$ifdef UNIX}
class function Shell.FindIcon(icon:string; size:integer):string;
var
  filename,stheme:string;
begin
  stheme:='Adwaita';
  filename := Shell.FindIconHelper(icon, size, sTheme);
  if filename <>'' then
    exit(filename);

  filename := Shell.FindIconHelper(icon, size, 'hicolor');
  if filename <>'' then
    exit(filename);

  exit(LookupFallbackIcon(icon));
end;

class function Shell.FindIconHelper(icon:string; size:integer; theme:string):string;
var
  ini:TMemIniFile;
  i:integer;
  filename,parents:string;
  lst:TStrLst;
begin
  filename := LookupIcon (icon, size, theme);
  if filename<>'' then
    exit(filename);

  // if theme has parents
  ini:=TMemIniFile.Create('/usr/share/icons/'+theme+'/index.theme');
  try
    parents:=ini.ReadString('Icon Theme','inherits','');
    if parents='' then exit('');
  finally
    ini.Free;
  end;
  splitresp(parents,',',lst);
  for i:=0 to high(lst) do
  begin
    filename := FindIconHelper (icon, size, lst[i]{parent});
    if (filename<>'') then
      exit(filename);
  end;

  Result:='';
end;

const ext_list:array[0..2] of string[3]=('png', 'svg', 'xpm');

class function Shell.LookupIcon(const iconname:string; size:integer;const theme:string):string;
var
  ini:TMemIniFile;
  filename,subdir,dirs,closest_filename:string;
  i,j,minimal_size,sz:integer;
  lst,slst:TStrLst;
begin
 (* Result:='';
  ini:=TmemIniFile.Create('/usr/share/icons/'+theme+'/index.theme');
  try
    dirs:=ini.ReadString('Icon Theme','','Directories');
    if dirs='' then exit('');
  finally
    ini.Free;
  end;
  splitresp(dirs,',',lst);
  for i:=0 to high(lst) do
  begin
    splitresp(lst[i],'/',slst);
    for j:=0 to high(ext_list) do
    begin
      if DirectoryMatchesSize(slst[0],size) then
      begin
        filename:='/usr/share/icons/'+theme+'/'+lst[i]+'/'+iconname+'.'+ext_list[j];
        if FileSystem.FileExistsUTF8(filename) then
        exit(filename);
      end;
    end;
  end;

  closest_filename:='';
  minimal_size := MAXINT;
  for i:=0 to high(lst) do
  begin
    splitresp(lst[i],'/',slst);
    for j:=0 to high(ext_list) do
    begin
      filename:='/usr/share/icons/'+theme+'/'+lst[i]+'/'+iconname+'.'+ext_list[j];
      if FileSystem.FileExistsUTF8(filename) then
      begin
        sz:=DirectorySizeDistance(lst[i], size);
        if sz< minimal_size then
        begin
          closest_filename := filename;
          minimal_size := sz;
        end;
      end;
      exit(filename);

    end;
  end;

  if closest_filename<>'' then
     exit(closest_filename);
  *)
end;

class function Shell.LookupFallbackIcon (const iconname:string):string;
begin
 (* for each directory in $(basename list) {
    for extension in ("png", "svg", "xpm") {
      if exists directory/iconname.extension
        return directory/iconname.extension
    }
  }*)
  exit('');// none
end;

class function Shell.DirectoryMatchesSize(const subdir:string; iconsize:integer):boolean;
begin
 (* read Type and size data from subdir
  if Type is Fixed
    return Size == iconsize
  if Type is Scaled
    return MinSize <= iconsize <= MaxSize
  if Type is Threshold
    return Size - Threshold <= iconsize <= Size + Threshold
    *)
end;

type

  { TfdTheme }

  // FreeDesktop theme loader
  TfdTheme=class
    ini:TMemIniFile;
    constructor Create(const theme:string);
    destructor Destroy;override;
    function DirectorySizeDistance(const subdir:string; size:integer):integer;
  end;

{ TfdTheme }

constructor TfdTheme.Create(const theme: string);
begin
  ini:=TMemIniFile.Create('/usr/share/icons/'+theme+'/index.theme');
end;

destructor TfdTheme.Destroy;
begin
  ini.free;
  inherited Destroy;
end;

function TfdTheme.DirectorySizeDistance(const subdir:string; size:integer):integer;
var
  iconsize,minsize,maxsize,threshold:integer;
  stype,smin,smax:string;
begin
  stype:=ini.ReadString(subdir,'Type','');
  iconsize:=ini.ReadInteger(subdir,'Size',0);

  if stype='Fixed' then
     exit(abs(size-iconsize));

  if stype='Scaled' then
  begin
    minsize:=ini.ReadInteger(subdir,'MinSize',0);
    maxsize:=ini.ReadInteger(subdir,'MaxSize',0);
    if (iconsize<minsize) then
      exit(MinSize - iconsize);
    if (iconsize>MaxSize) then
      exit(iconsize - MaxSize);
    exit(0); // exact
  end;

  if stype='Threshold' then
  begin

  end;

  (*

  if Type is Scaled
    if iconsize < MinSize
        return MinSize - iconsize
    if iconsize > MaxSize
        return iconsize - MaxSize
    return 0
  if Type is Threshold
    if iconsize < Size - Threshold
        return MinSize - iconsize
    if iconsize > Size + Threshold
        return iconsize - MaxSize
    return 0
  *)
end;
{$endif}


end.
desk.pas (12,353 bytes)   

jcmartini

2021-02-25 11:39

reporter   ~0129156

Thanks a lot Anton

wp

2021-03-05 19:25

developer   ~0129406

Last edited: 2021-03-06 12:33

View 2 revisions

Anton, maybe I am blind (as usual...), but I think your unit is not very helpful because it seems ti require a variety of non-standard units. Are you sure that the directories mentioned in your code are valid for all Linux systems? Has can I determine which theme is used currently?

wp

2021-03-07 16:07

developer   ~0129486

Widgetset-based solutions for TShellTreeView in r64747 and for TShellListView in r64764., windows-only for the moment.

I am a bit in doubt whether Anton Kavalenka's code is general enough to hold for all kinds of Linux installations. I think it would be better to seek for solutions provided by the gtk2/gkt3 and qt4/qt5 libraries directly. Keeping the issue open...

Issue History

Date Modified Username Field Change
2010-12-17 23:30 lainz New Issue
2010-12-17 23:30 lainz Widgetset => Win32/Win64
2010-12-18 10:18 Vincent Snijders LazTarget => -
2010-12-18 10:18 Vincent Snijders Assigned To => Felipe Monteiro de Carvalho
2010-12-18 10:18 Vincent Snijders Status new => assigned
2011-06-28 15:56 lainz Tag Attached: ListView
2013-07-27 00:32 Bart Broersma Note Added: 0069126
2015-08-13 13:35 lainz Note Added: 0085331
2015-08-15 09:01 Felipe Monteiro de Carvalho Note Added: 0085363
2015-08-16 00:26 Janusz Tomczak Note Added: 0085384
2017-11-23 10:01 PeterX Note Added: 0104220
2017-11-23 15:29 Bart Broersma Note Added: 0104231
2021-02-24 18:52 Juha Manninen Assigned To Felipe Monteiro de Carvalho => wp
2021-02-24 18:53 Juha Manninen Note Added: 0129149
2021-02-24 19:44 wp Note Added: 0129150
2021-02-24 20:32 Anton Kavalenka Note Added: 0129151
2021-02-24 20:32 Anton Kavalenka File Added: desk.pas
2021-02-24 20:32 Anton Kavalenka Note Edited: 0129151 View Revisions
2021-02-25 11:39 jcmartini Note Added: 0129156
2021-03-05 19:25 wp Note Added: 0129406
2021-03-06 12:33 wp Note Edited: 0129406 View Revisions
2021-03-07 16:07 wp Note Added: 0129486