Chip 2002 March/Chip_2002-03_cd1.bin/zkuste/delphi/kompon/d3456/SYSIMAGE.ZIP/SysImg.pas

Pascal/Delphi Source File | 2001-12-27 | 6.0 KB | 195 lines

{------------------------------------------------------------------------------}
{                                                                              }
{  TSysImageList v1.20                                                         }
{  by Kambiz R. Khojasteh                                                      }
{                                                                              }
{  [e-mail]                                                       }
{  http://www.delphiarea.com                                                   }
{                                                                              }
{------------------------------------------------------------------------------}

{$I DELPHIAREA.INC}

unit SysImg;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  {$IFDEF DELPHI4_UP} ImgList {$ELSE} ComCtrls {$ENDIF};

type

  TIconSize = (isSmallIcons, isLargeIcons);

  {$IFDEF DELPHI4_UP}
  TSysImageList = class(TCustomImageList)
  {$ELSE}
  TSysImageList = class(TImageList)
  {$ENDIF}
  private
    fIconSize: TIconSize;
    procedure SetIconSize(Value: TIconSize);
    procedure UpdateHandle;
  protected
    procedure DefineProperties(Filer: TFiler); override;
  public
    constructor Create(AOwner: TComponent); override;
    function ImageIndexOf(const Path: String; OpenIcon: Boolean
      {$IFDEF DELPHI4_UP} = False {$ENDIF}): Integer;
  published
    Property BkColor;
    Property BlendColor;
    property DrawingStyle default dsTransparent;
    property IconSize: TIconSize read fIconSize write SetIconSize default isSmallIcons;
    property OnChange;
  end;

procedure Register;

implementation

uses
  ShellAPI, ShlObj, ActiveX;

type
  TSpecialFolder = record
    Name: String;
    ID: Integer;
  end;

const
  IconSizeFlags: array[TIconSize] of Word =
    (SHGFI_SMALLICON, SHGFI_LARGEICON);
  OPenIconFlags: array[Boolean] of Word =
    (0, SHGFI_OPENICON);
  SpecialFolders: array[1..7] of TSpecialFolder = (
    (Name: 'Desktop';              ID: CSIDL_DESKTOP),
    (Name: 'Control Panel';        ID: CSIDL_CONTROLS),
    (Name: 'Printers';             ID: CSIDL_PRINTERS),
    (Name: 'My Documents';         ID: CSIDL_PERSONAL),
    (Name: 'Recycle Bin';          ID: CSIDL_BITBUCKET),
    (Name: 'My Computer';          ID: CSIDL_DRIVES),
    (Name: 'Network Neighborhood'; ID: CSIDL_NETWORK));

constructor TSysImageList.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  fIconSize := isSmallIcons;
  DrawingStyle := dsTransparent;
  ShareImages := True;
  UpdateHandle;
end;

procedure TSysImageList.DefineProperties(Filer: TFiler);
begin
  Handle := 0;
  inherited DefineProperties(Filer);
  UpdateHandle;
end;

procedure TSysImageList.UpdateHandle;
var
  FileInfo: TShFileInfo;
begin
  Handle := ShGetFileInfo('C:\', 0, FileInfo, SizeOf(FileInfo),
    IconSizeFlags[fIconSize] or SHGFI_SYSICONINDEX);
end;

function GetUniqueFileName: String;
var
  TempPath: array[0..255] of Char;
  TempFile: array[0..255] of Char;
begin
  GetTempPath(SizeOf(TempPath), TempPath);
  GetTempFileName(TempPath, 'TMP', Random(100), TempFile);
  Result := TempFile;
end;

function TSysImageList.ImageIndexOf(const Path: String; OpenIcon: Boolean): Integer;

var
  FileInfo: TShFileInfo;
  DesktopFolder: IShellFolder;
  PIDL: PItemIDList;
  Malloc: IMalloc;
  NumChars, Flags: {$IFDEF DELPHI4_UP} Cardinal {$ELSE} LongInt {$ENDIF};
  WidePath: PWideChar;
  SpecialFolderID, Index: Integer;
  FileExt, TempFileName: String;
  TempFile: THandle;
begin
  Result := 0;
  // Looks for special folders
  SpecialFolderID := -1;
  for Index := Low(SpecialFolders) to High(SpecialFolders) do
    if CompareText(Path, SpecialFolders[Index].Name) = 0 then
    begin
      SpecialFolderID := SpecialFolders[Index].ID;
      Break;
    end;
  if SpecialFolderID >= 0 then
    SHGetSpecialFolderLocation(Application.Handle, SpecialFolderID, PIDL)
  else // If the path is not a special folder, we get its PIDL by using desktop folder
  begin
    Flags := 0;
    WidePath := StringToOleStr(Path);
    NumChars := Length(WidePath);
    SHGetDesktopFolder(DesktopFolder);
    DesktopFolder.ParseDisplayName(0, nil, WidePath, NumChars, PIDL, Flags);
  end;
  // If PIDL is obtained, we use it for finding the image index. When path is not
  // a URL or an existing file, PIDL could be null.
  if PIDL <> nil then
  begin
    FillChar(FileInfo, SizeOf(FileInfo), 0);
    ShGetFileInfo(PChar(PIDL), 0, FileInfo, SizeOf(FileInfo), SHGFI_PIDL or
      SHGFI_SYSICONINDEX or IconSizeFlags[fIconSize] or OpenIconFlags[OpenIcon]);
    if FileInfo.iIcon > 0 then Result := FileInfo.iIcon;
    ShGetMalloc(Malloc);
    Malloc.Free(PIDL);
  end
  else
  begin
    // If PIDL is null, we try to find the image index by using the file type
    FileExt := ExtractFileExt(Path);
    FillChar(FileInfo, SizeOf(FileInfo), 0);
    ShGetFileInfo(PChar('*' + FileExt), 0, FileInfo, SizeOf(FileInfo),
      SHGFI_SYSICONINDEX or IconSizeFlags[fIconSize] or OpenIconFlags[OpenIcon]);
    if FileInfo.iIcon > 0 then
      Result := FileInfo.iIcon
    else if not FileExists(Path) then
    begin
      // If using file type failed and path does not point to an existing file,
      // we create a temporary file as type of the file. If there is any icon
      // associated to the type, we will have it.
      TempFileName := GetUniqueFileName + FileExt;
      TempFile := FileCreate(TempFileName);
      if TempFile > 0 then
        FileClose(TempFile);
      if FileExists(TempFileName) then
        try
          Result := ImageIndexOf(TempFileName, OpenIcon);
        finally
          DeleteFile(TempFileName);
        end;
    end;
  end;
end;

procedure TSysImageList.SetIconSize(Value: TIconSize);
begin
  if fIconSize <> Value then
  begin
    fIconSize := Value;
    UpdateHandle;
  end;
end;

procedure Register;
begin
  RegisterComponents('Delphi Area', [TSysImageList]);
end;

end.