{
ShellImageList.pas
TImageList variants providing the shell's set of icons for an explorer
like view.
Version 1.3a
Copyright (C) 1998-2008 Volker Siebert
All rights reserved.
Permission is hereby granted, free of charge, to any person obtaining a
copy of this software and associated documentation files (the "Software"),
to deal in the Software without restriction, including without limitation
the rights to use, copy, modify, merge, publish, distribute, sublicense,
and/or sell copies of the Software, and to permit persons to whom the
Software is furnished to do so, subject to the following conditions:
The above copyright notice and this permission notice shall be included in
all copies or substantial portions of the Software.
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
DEALINGS IN THE SOFTWARE.
}
unit ShellImageList;
interface
uses
Windows, Messages, SysUtils, Classes, Controls, ImgList, ShlObj;
type
TCustomShellImageList =
class(TCustomImageList)
protected
FHandle: DWORD;
FDefaultFileImageIndex: Integer;
FFolderImageIndex:
array [Boolean]
of Integer;
FSizeFlag: UINT;
FWorkingDirectory:
string;
function GetIconIndex(
const Name:
string; MoreFlags: DWORD = 0): Integer;
public
constructor Create(AOwner: TComponent);
override;
destructor Destroy;
override;
function ImageIndexForExtension(
const Extension:
string): Integer;
function ImageIndexForFileName(
const FileName:
string): Integer;
function ImageIndexForFilePath(
const FilePath:
string): Integer;
function ImageIndexForFolder(Selected: Boolean): Integer;
function ImageIndexForPidl(Pidl: PItemIdList): Integer;
function ImageIndexForShellFolder(
const Index: Integer): Integer;
property DefaultFileImageIndex: Integer
read FDefaultFileImageIndex;
property NormalFolderImageIndex: Integer
read FFolderImageIndex[False];
property SelectedFolderImageIndex: Integer
read FFolderImageIndex[True];
end;
TSmallShellImageList =
class(TCustomShellImageList)
public
constructor Create(AOwner: TComponent);
override;
end;
TLargeShellImageList =
class(TCustomShellImageList)
public
constructor Create(AOwner: TComponent);
override;
end;
function GetShellImageListHandle(Small: Boolean): THandle;
procedure Register;
implementation
uses
ActiveX, ComObj, ShellApi;
{ The handle of the image list is managened by the shell API, either globally
(Windows 95/98/ME) or on a per-process basis (Windows NT/2K/XP/Vista).
This is to ensure that image list indexes are valid with each variant of
the shell image list.
More info at <http://support.microsoft.com/kb/q234310/en/> and
<http://support.microsoft.com/kb/q192055/en/>.
We create a new folder in the temporary directory. This is used to query
icons for normal folders and for all files that do not really exist.
Note that this doesn't work for filenames that have an icon handler because
the file doesn't really exist. These are e.g. EXE, ICO, CUR, and TTF. They
get a standard symbol assigned by the shell.
}
function GetShellImageListHandle(Small: Boolean): THandle;
var
List: TCustomShellImageList;
begin
if Small
then
List := TSmallShellImageList.Create(
nil)
else
List := TLargeShellImageList.Create(
nil);
try
Result := List.Handle;
finally
List.Free;
end;
end;
{ Returns the fully qualified path to the temporary directory,
always including a trailing backslash.
}
function TempDirectory:
string;
function CheckDir(
const d:
string):
string;
begin
if (d = '
')
or not DirectoryExists(d)
then
Result := '
'
else
Result := IncludeTrailingPathDelimiter(ExpandFileName(d));
end;
begin
if CachedTempDirectory = '
'
then
begin
CachedTempDirectory := CheckDir(GetEnvironmentVariable('
TMP'));
if CachedTempDirectory = '
'
then
CachedTempDirectory := CheckDir(GetEnvironmentVariable('
TEMP'));
if CachedTempDirectory = '
'
then
if Win32Platform = VER_PLATFORM_WIN32_NT
then
CachedTempDirectory := CheckDir(GetEnvironmentVariable('
USERPROFILE'));
if CachedTempDirectory = '
'
then
CachedTempDirectory := IncludeTrailingPathDelimiter(WindowsDirectory);
end;
Result := CachedTempDirectory;
end;
{ TCustomShellImageList }
constructor TCustomShellImageList.Create(AOwner: TComponent);
procedure GetOverlayImages;
var
TempFile:
string;
WideName: WideString;
DesktopFolder, TempDirFolder: IShellFolder;
Malloc: IMalloc;
IconOverlay: IShellIconOverlay;
pidlTempDir, pidlTempFile: PItemIdList;
FileHandle: THandle;
Eaten, Attributes: DWORD;
OverlayIndex: Integer;
begin
// See <http://support.microsoft.com/kb/q192055/en/>
if FAILED(SHGetMalloc(Malloc))
then
Exit;
pidlTempDir :=
nil;
pidlTempFile :=
nil;
try
if FAILED(SHGetDesktopFolder(DesktopFolder))
then
Exit;
TempFile := Format('
temp%d.lnk', [GetCurrentProcessId]);
FileHandle := CreateFile(PChar(FWorkingDirectory + TempFile),
GENERIC_WRITE, 0,
nil, CREATE_NEW, FILE_ATTRIBUTE_NORMAL, 0);
CloseHandle(FileHandle);
try
WideName := FWorkingDirectory;
Attributes := 0;
if FAILED(DesktopFolder.ParseDisplayName(0,
nil, PWideChar(WideName),
Eaten, pidlTempDir, Attributes))
then
Exit;
if FAILED(DesktopFolder.BindToObject(pidlTempDir,
nil,
IID_IShellFolder, TempDirFolder))
then
Exit;
if not Supports(TempDirFolder, IShellIconOverlay, IconOverlay)
then
Exit;
WideName := TempFile;
Attributes := 0;
if FAILED(TempDirFolder.ParseDisplayName(0,
nil, PWideChar(WideName),
Eaten, pidlTempFile, Attributes))
then
Exit;
IconOverlay.GetOverlayIndex(pidlTempFile, OverlayIndex);
finally
DeleteFile(PChar(FWorkingDirectory + TempFile));
end;
finally
if pidlTempDir <>
nil then
Malloc.Free(pidlTempDir);
if pidlTempFile <>
nil then
Malloc.Free(pidlTempFile);
end;
end;
begin
inherited;
// Get an empty working directory
FWorkingDirectory := IncludeTrailingPathDelimiter(TempDirectory) +
'
{EEB74622-1B97-4687-84B6-11D85542A91E}'
;
ForceDirectories(FWorkingDirectory);
FWorkingDirectory := IncludeTrailingPathDelimiter(FWorkingDirectory);
FFolderImageIndex[False] := GetIconIndex('
');
FFolderImageIndex[True ] := GetIconIndex('
', SHGFI_OPENICON);
FDefaultFileImageIndex := GetIconIndex(FWorkingDirectory + '
Dummy');
if Win32Platform = VER_PLATFORM_WIN32_NT
then
GetOverlayImages;
end;
destructor TCustomShellImageList.Destroy;
begin
RemoveDir(FWorkingDirectory);
inherited;
end;
function TCustomShellImageList.GetIconIndex(
const Name:
string; MoreFlags: DWORD): Integer;
var
Full:
string;
Attr, Flags: DWORD;
Info: TSHFileInfo;
Hdl: DWORD;
begin
Flags := FSizeFlag
or SHGFI_SYSICONINDEX
or SHGFI_USEFILEATTRIBUTES
or
(MoreFlags
and $ffffff);
if Name = '
'
then
begin
Full := ExcludeTrailingPathDelimiter(FWorkingDirectory);
Attr := FILE_ATTRIBUTE_DIRECTORY;
end
else
begin
Full :=
Name;
if MoreFlags
and $10000000 <> 0
then
Attr := FILE_ATTRIBUTE_NORMAL
else
begin
Attr := GetFileAttributes(PChar(Full));
if Attr = DWORD(-1)
then
Attr := FILE_ATTRIBUTE_NORMAL;
end;
end;
FillChar(Info, SizeOf(Info), 0);
Hdl := SHGetFileInfo(PChar(Full), Attr, Info, SizeOf(Info), Flags);
if Hdl = 0
then
begin
if FHandle = 0
then
RaiseLastOSError;
Result := -1;
end
else
begin
if FHandle = 0
then
begin
Handle := Hdl;
ShareImages := True;
FHandle := Hdl;
end;
Result := Info.iIcon;
end;
end;
function TCustomShellImageList.ImageIndexForExtension(
const Extension:
string): Integer;
begin
if Extension = '
'
then
Result := FDefaultFileImageIndex
else if Extension[1] = '
.'
then
Result := GetIconIndex(FWorkingDirectory + '
Dummy' + Extension)
else
Result := GetIconIndex(FWorkingDirectory + '
Dummy.' + Extension)
end;
function TCustomShellImageList.ImageIndexForFileName(
const FileName:
string): Integer;
begin
if FileName = '
'
then
Result := FDefaultFileImageIndex
else
Result := GetIconIndex(FWorkingDirectory + FileName, $10000000);
end;
function TCustomShellImageList.ImageIndexForFilePath(
const FilePath:
string): Integer;
begin
if FilePath = '
'
then
Result := FDefaultFileImageIndex
else
Result := GetIconIndex(FilePath);
end;
function TCustomShellImageList.ImageIndexForFolder(Selected: Boolean): Integer;
begin
Result := FFolderImageIndex[Selected];
end;
function TCustomShellImageList.ImageIndexForPidl(Pidl: PItemIdList): Integer;
var
Info: TSHFileInfo;
Flags: DWORD;
begin
if Pidl =
nil then
Result := FDefaultFileImageIndex
else
begin
Flags := FSizeFlag
or SHGFI_SYSICONINDEX
or SHGFI_PIDL;
if SHGetFileInfo(PChar(Pidl), 0, Info, SizeOf(Info), Flags) = 0
then
RaiseLastOSError;
Result := Info.iIcon;
end;
end;
function TCustomShellImageList.ImageIndexForShellFolder(
const Index: Integer): Integer;
var
pidl: PItemIdList;
Info: TSHFileInfo;
Malloc: IMalloc;
Flags: DWORD;
begin
Result := NormalFolderImageIndex;
pidl :=
nil;
try
if SUCCEEDED(SHGetSpecialFolderLocation(0,
Index, pidl))
then
begin
FillChar(Info, SizeOf(Info), 0);
Flags := FSizeFlag
or SHGFI_SYSICONINDEX
or SHGFI_PIDL;
if SHGetFileInfo(PChar(pidl), 0, Info, SizeOf(Info), Flags) <> 0
then
Result := Info.iIcon;
end;
finally
if pidl <>
nil then
if SUCCEEDED(SHGetMalloc(Malloc))
then
Malloc.Free(pidl);
end;
end;
{ TSmallShellImageList }
constructor TSmallShellImageList.Create(AOwner: TComponent);
begin
FSizeFlag := SHGFI_SMALLICON;
inherited;
end;
{ TLargeShellImageList }
constructor TLargeShellImageList.Create(AOwner: TComponent);
begin
FSizeFlag := SHGFI_LARGEICON;
inherited;
end;
{ Registration }
procedure Register;
begin
RegisterComponents('
Flocke', [TSmallShellImageList, TLargeShellImageList]);
end;
end.