Shell Icons

Her er koden til en komponent som jeg ikke selv har lavet men som er freeware (exempel kode i bunden):

{*************************************************************}
{            Shell Extension Component for Delphi 32          }
{ Version:  1.2                                              }
{ E-Mail:    info@utilmind.com                                }
{ Home Page: www.utilmind.com                                }
{ Created:  April 15, 1999                                  }
{ Modified:  October 27, 1999                                }
{ Legal:    Copyright (c) 1999, UtilMind Solutions          }
{*************************************************************}
{  TShellExt                                                }
{ Component working with ShellExtension through the system    }
{ registry, because standard functions is undocumented in    }
{ WinAPI32. Is intended for assuming to files if the          }
{ Shell-links with the executable applications with setting  }
{ personal icon. Moreover it is possible extract from Shell  }
{ the information about a file (its executable application,  }
{ icon, description).                                        }
{*************************************************************}
{ PROPERTIES:                                                }
{  Icon: TIcon - Icon of Shell Extension (Result of          }
{                GetShellExtension function)                }
{  IconIndex: Integer -  Used for Install only              }
{                        (icon index in .exe or .dll)        }
{  ExtDescription: String - Description of Extension        }
{                          uses in System Registry            }
{  FileDescription: String - Description of File Type        }
{  Extension: String - File extension (.txt or .pas erc)    }
{  OpenWith: String - Extension opens with this [filename]  }
{  OpenWithMe: Boolean - Open with current .exe project      }
{  ParamString: String - Run parameters. Usualy \'%1\'.        }
{ METHODS:                                                    }
{  Install - installs custom Shell-extension (icon must be  }
{            specified by IconIndex property)                }
{  UnInstall - unistalls Shell-extension                    }
{  GetShellExtension - extract ShellExtension into component }
{                      Icon property will be extension icon. }
{*************************************************************}
{ Please see demo program for more information.              }
{*************************************************************}
{                    IMPORTANT NOTE:                        }
{ This software is provided \'as-is\', without any express or  }
{ implied warranty. In no event will the author be held      }
{ liable for any damages arising from the use of this        }
{ software.                                                  }
{ Permission is granted to anyone to use this software for    }
{ any purpose, including commercial applications, and to      }
{ alter it and redistribute it freely, subject to the        }
{ following restrictions:                                    }
{ 1. The origin of this software must not be misrepresented,  }
{    you must not claim that you wrote the original software. }
{    If you use this software in a product, an acknowledgment }
{    in the product documentation would be appreciated but is }
{    not required.                                            }
{ 2. Altered source versions must be plainly marked as such,  }
{    and must not be misrepresented as being the original    }
{    software.                                                }
{ 3. This notice may not be removed or altered from any      }
{    source distribution.                                    }
{*************************************************************}

unit ShellExt;

interface

uses
  Windows, Classes, Graphics, Controls, Forms, SysUtils, Registry,
  ShellAPI;

type
  TShellExt = class(TComponent)
  private
    FIcon: TIcon;        { Used for GetShellExtension only }
    FExtension: String;
    FExtDescription: String; { For example \"UtilMind scheme file\" }
    FFileDescription: String; { Scheme file }
    FOpenWith: String; { For example \'D:\\ARM\\ARM.EXE\' (file will be opens as [arm.exe file.sh]) }
    FOpenWithMe: Boolean; { Open with current .exe file }
    FParamString: String; { For example %1 }
    FIconIndex: Integer; { Used for Install only (icon index in .exe or .dll) }
    procedure SetIcon(Value: TIcon);
    procedure SetExtension(Value: String);
    procedure SetOpenWith(Value: String);
    procedure SetOpenWithMe(Value: Boolean);
  public
    constructor Create(aOwner: TComponent); override;
    destructor Destroy; override;

    function Install: Boolean; { True if successful }
    function UnInstall: Boolean;
    function GetShellExtension: Boolean;
  published
    { See description above }
    property Icon: TIcon read FIcon write SetIcon;
    property IconIndex: Integer read FIconIndex write FIconIndex;
    property ExtDescription: String read FExtDescription write FExtDescription;
    property FileDescription: String read FFileDescription write FFileDescription;
    property Extension: String read FExtension write SetExtension;
    property OpenWith: String read FOpenWith write SetOpenWith;
    property OpenWithMe: Boolean read FOpenWithMe write SetOpenWithMe;
    property ParamString: String read FParamString write FParamString;
  end;

procedure Register;

implementation

constructor TShellExt.Create(aOwner: TComponent);
begin
  inherited Create(aOwner);
  FOpenWith := \'[Self]\';
  FOpenWithMe := True;
  FIcon := TIcon.Create;
end;

destructor TShellExt.Destroy;
begin
  FIcon.Destroy;
  inherited Destroy;
end;

procedure TShellExt.SetIcon(Value: TIcon);
begin
  if FIcon <> Value then FIcon.Assign(Value);
end;

procedure TShellExt.SetExtension(Value: String);
begin
  if FExtension <> Value then
  begin
    FExtension := Value;
  end;
end;

procedure TShellExt.SetOpenWith(Value: String);
begin
  if not FOpenWithMe and (FOpenWith <> Value) then
  begin
    FOpenWith := Value;
  end;
end;

procedure TShellExt.SetOpenWithMe(Value: Boolean);
begin
  FOpenWithMe := Value;
  if Value then
  if not (csDesigning in ComponentState) then
    FOpenWith := Application.ExeName
  else FOpenWith := \'[Self]\';
end;

function TShellExt.Install: Boolean;
var
  Reg: TRegistry;
begin
  Reg := TRegistry.Create;
  try
    with Reg do
    begin
      RootKey := HKEY_CLASSES_ROOT;
      OpenKey(FExtension, True);
      WriteString(\'\', FExtDescription);
      OpenKey(\'\\\' + FExtDescription, True);
      WriteString(\'\', FFileDescription);
      OpenKey(\'DefaultIcon\', True);
      WriteString(\'\', OpenWith + \',\'+IntToStr(FIconIndex));
      OpenKey(\'\\\' + FExtDescription + \'\\Shell\\Open\\Command\', True);
      WriteString(\'\', \'\"\' + OpenWith + \'\" \"\' + FParamString + \'\"\');
    end;
  Result := True; 
  except
  Result := False;
  end;
  Reg.Free;
end;

function TShellExt.UnInstall: Boolean;
var
  Reg: TRegistry;
begin
  Reg := TRegistry.Create;
  try
    with Reg do
    begin
      RootKey := HKEY_CLASSES_ROOT;
      DeleteKey(FExtension);
      DeleteKey(\'\\\' + FExtDescription);
    end;
  Result := True;
  except
  Result := False;
  end;
  Reg.Free;
end;

function TShellExt.GetShellExtension: Boolean;
var
  Reg: TRegistry;
  IconFileName, IconIndex: String;
  PC: Array[0..$FF] of Char;
  i, j: Integer;

  procedure SplitStr(SplitChar: Char; var Str, Str1: String);
  var
    i: Integer;
  begin
    i := Pos(SplitChar, Str);
    if i <> 0 then
    begin
      Str1 := Copy(Str, i + 1, Length(Str) - i + 1);
      SetLength(Str, i - 1);
    end
    else FParamString := \'\';
  end;

begin
  Reg := TRegistry.Create;
  try
    with Reg do
    begin
      RootKey := HKEY_CLASSES_ROOT;
      OpenKey(FExtension, True);
      FExtDescription := ReadString(\'\');
      OpenKey(\'\\\' + FExtDescription, True);
      FFileDescription := ReadString(\'\');
      OpenKey(\'DefaultIcon\', True);

      IconFileName := ReadString(\'\');
      SplitStr(\',\', IconFileName, IconIndex);
      StrPCopy(PC, IconFileName);

      FIcon.Handle := ExtractIcon(0, PC, StrToInt(IconIndex));
      OpenKey(\'\\\' + FExtDescription + \'\\Shell\\Open\\Command\', True);
      FOpenWithMe := False;
      FOpenWith := ReadString(\'\');

      i := Pos(\'\"\', FOpenWith);
      if i = 1 then
      begin
        FOpenWith := Copy(FOpenWith, 2, Length(FOpenWith) - 1);
        i := Pos(\'\"\', FOpenWith);
        FParamString := Copy(FOpenWith, i + 2, Length(FOpenWith) - i - 1);
        j := Pos(\'\"\', FParamString);
        while j <> 0 do
        begin
          Delete(FParamString, j, 1);
          j := Pos(\'\"\', FParamString);
        end;
        FOpenWith := Copy(FOpenWith, 0, i - 1);
      end
      else SplitStr(\' \', FOpenWith, FParamString)
    end;
    Result := True;
  except
  Result := False;
  end;
  Reg.Free;
end;

procedure Register;
begin
  RegisterComponents(\'UtilMind\', [TShellExt]);
end;

end.

{ Og så kan du så bruge den således:
// Advanced er navnet på en instance af komponenten
  Advanced.Extension := \'.wav\';

  if Advanced.GetShellExtension then
  begin
    Image.Picture.Icon.Assign(Advanced.Icon);
    Label7.Caption := Advanced.FileDescription;
    Label8.Caption := Advanced.ExtDescription;
    Label9.Caption := Advanced.OpenWith;
    Label10.Caption := Advanced.ParamString;
  end;
}

Hope this helps. Den kan jo så kaldes en masse gange.

Det er meget godt med den komponent men den kan ikke vise ikoner for de forskellige *.exe filer.

Eksempel:
ikonet for spillet Quake3.exe er jo ikke den samme som ikonet for programmet 3dsmax.exe ...

Så hvordan får man de forskellige *.exe ikoner frem. Please help...

Meget gerne eksempler...

ZeroHero

I så fald skal du blot kikke i dit Delphi bibliotek, under Demos\\ResExplor, der har du et program som kan hive netop ikonerne ud!! (Iøvrigt er Demos biblioteket et udemærket sted at starte med at lære nogle forskellige ting)

Ok, 1000 tak for hjælpen kim... du får dine fortjente points...

til TListView er der en MEGET simpel løsning: bare lad Windows klare jobbet med ikonerne - hvordan:
find_system_iconer opretter TImageList\'s for en TListView (kaldet ListView1) og sætter dem til at pege på Windows system Icon-liste (kaldes kun EN gang - fx. i OnCreate til formen). Opdater opdaterer ListView1 for den pågældende mappe (angivet som parameteren Dir) - så er det bare at fange dobbelt-klik osv...

procedure TForm1.find_system_iconer;
var SHFileInfo: TSHFileInfo;
begin
    with ListView1 do
    begin
          SmallImages := TImageList.CreateSize(16,16);
          SmallImages.ShareImages := True;
          SmallImages.Handle := ShGetFileInfo(\'*.*\', 0, SHFileInfo, SizeOf(SHFileInfo), SHGFI_SMALLICON or SHGFI_ICON or SHGFI_SYSICONINDEX);
          LargeImages := TImageList.Create(nil);
          LargeImages.ShareImages := True;
          LargeImages.Handle := ShGetFileInfo(\'*.*\', 0, SHFileInfo, SizeOf(SHFileInfo), SHGFI_LARGEICON or SHGFI_ICON or SHGFI_SYSICONINDEX);
    end;
end;

og så:
procedure TForm1.Opdater(Dir : String);
  var Found    : Integer;
      SearchRec : TSearchRec;
      SHFileInfo: TSHFileInfo;
begin
  Listview1.Items.Clear;
  Found := FindFirst(Dir + \'\\*.*\', faAnyFile, SearchRec);
  While Found = 0 do
  begin
    If SearchRec.Name[1] <> \'.\' then
    begin
      ShGetFileInfo(PChar(SearchRec.Name), 0, SHFileInfo, SizeOf(SHFileInfo), SHGFI_SMALLICON or SHGFI_SYSICONINDEX);
      with Listview1.Items.add do
      begin
          Caption := SearchRec.Name;
          ImageIndex := SHFileInfo.iIcon;
      end;
    end;
    Found := FindNext(SearchRec);
  end;
  FindClose(SearchRec);
end;

Michael

Rettelse:
  If SearchRec.Name[1] <> \'.\' then
    begin
      ShGetFileInfo(PChar(Dir + \'\\\' + SearchRec.Name) ...

Det er ikke sikkert det er nødvendigt - men bare for at være på den sikre side...

Michael