unit GetBigIcon;

interface

uses ShellApi, Commctrl, ShlObj, Windows, Sysutils, Graphics;

const
 SHIL_LARGE     = $00; //The image size is normally 32x32 pixels. However, if the Use large icons option is selected from the Effects section of the Appearance tab in Display Properties, the image is 48x48 pixels.
 SHIL_SMALL     = $01;  //These images are the Shell standard small icon size of 16x16, but the size can be customized by the user.
 SHIL_EXTRALARGE= $02;  //These images are the Shell standard extra-large icon size. This is typically 48x48, but the size can be customized by the user.
 SHIL_SYSSMALL  = $03;  //These images are the size specified by GetSystemMetrics called with SM_CXSMICON and GetSystemMetrics called with SM_CYSMICON.
 SHIL_JUMBO     = $04;  //Windows Vista and later. The image is normally 256x256 pixels.
 IID_IImageList: TGUID= '{46EB5926-582E-4017-9FDF-E8998DAA0950}';

Procedure GetIconFromFile(aFile:String; var aIcon : TIcon; SHIL_FLAG: Cardinal);

implementation

 function GetImageListSH(SHIL_FLAG:Cardinal): HIMAGELIST;
 type  _SHGetImageList = function (iImageList: integer; const riid: TGUID; var ppv: Pointer): hResult; stdcall;
 var  Handle: THandle;  SHGetImageList: _SHGetImageList;
 begin  Result:= 0;
 Handle:= LoadLibrary('Shell32.dll');
 if Handle<>S_OK then
 try
 SHGetImageList:=GetProcAddress(Handle, PChar(727));
 if Assigned(SHGetImageList) and (Win32Platform=VER_PLATFORM_WIN32_NT) then SHGetImageList(SHIL_FLAG, IID_IImageList, Pointer(Result));
 finally
 FreeLibrary(Handle);
 end;
 end;

 Procedure GetIconFromFile(aFile:String; var aIcon : TIcon; SHIL_FLAG: Cardinal);
 var  aImgList: HIMAGELIST;  SFI: TSHFileInfo;aIndex: integer;
 Begin
 FillChar(SFI,Sizeof(SFI),#0);
 SHGetFileInfo(PChar(aFile),0, SFI,SizeOf(TSHFileInfo),
 SHGFI_ICON or SHGFI_LARGEICON or SHGFI_SHELLICONSIZE or SHGFI_SYSICONINDEX or SHGFI_TYPENAME or SHGFI_DISPLAYNAME);
 if not Assigned(aIcon) then aIcon:= TIcon.Create;
 aImgList:= GetImageListSH(SHIL_FLAG);
 aIndex := SFI.iIcon;
 aIcon.Handle := ImageList_GetIcon( aImgList, aIndex, ILD_NORMAL );
 End;

end.

uses getbigicon;
...
procedure TForm1.Button1Click(Sender: TObject);
var ic:ticon;
begin
ic:=ticon.Create;
GetIconFromFile('c:\windows' {полный путь и имя папки или файла}, ic, SHIL_JUMBO); //SHIL_EXTRALARGE  //SHIL_LARGE
image1.Picture.Icon:=ic;
ic.Free;

aIcon.Handle := ImageList_GetIcon( aImgList, aIndex, ILD_NORMAL);

{  fStyle
Drawing style and, optionally, the overlay image. For information about specifying an overlay image index, see the comments section at the end of this topic. This parameter can be a combination of an overlay image index and one or more of the following values:
ILD_BLEND25,ILD_FOCUS
Draws the image, blending 25 percent with the system highlight color. This value has no effect if the image list does not contain a mask.
ILD_BLEND50,ILD_SELECTED,ILD_BLEND
Draws the image, blending 50 percent with the system highlight color. This value has no effect if the image list does not contain a mask.
ILD_MASK
Draws the mask.
ILD_NORMAL
Draws the image using the background color for the image list. If the background color is the CLR_NONE value, the image is drawn transparently using the mask.
ILD_TRANSPARENT
Draws the image transparently using the mask, regardless of the background color. This value has no effect if the image list does not contain a mask.}

unit ShellObjHelper;

{$IFDEF VER100}{$DEFINE DELPHI3}{$ENDIF}

interface

uses
 Windows, ShlObj, ActiveX, ShellAPI, Graphics, StrUtils;

type
 { from ShlObjIdl.h }
 IExtractImage = interface
   ['{BB2E617C-0920-11D1-9A0B-00C04FC2D6C1}']
   function GetLocation(Buffer: PWideChar;
                        BufferSize: DWORD;
                        var Priority: DWORD;
                        var Size: TSize;
                        ColorDepth: DWORD;
                        var Flags: DWORD): HResult; stdcall;
   function Extract(var BitmapHandle: HBITMAP): HResult; stdcall;
 end;

 IRunnableTask = interface
   ['{85788D00-6807-11D0-B810-00C04FD706EC}']
   function Run: HResult; stdcall;
   function Kill(fWait: BOOL): HResult; stdcall;
   function Suspend: HResult; stdcall;
   function Resume: HResult; stdcall;
   function IsRunning: Longint; stdcall;
 end;

const
 { from ShlObjIdl.h }
 ITSAT_MAX_PRIORITY      = 2;
 ITSAT_MIN_PRIORITY      = 1;
 ITSAT_DEFAULT_PRIORITY  = 0;

 IEI_PRIORITY_MAX        = ITSAT_MAX_PRIORITY;
 IEI_PRIORITY_MIN        = ITSAT_MIN_PRIORITY;
 IEIT_PRIORITY_NORMAL    = ITSAT_DEFAULT_PRIORITY;

 IEIFLAG_ASYNC     = $001; // ask the extractor if it supports ASYNC
extract
                           // (free threaded)
 IEIFLAG_CACHE     = $002; // returned from the extractor if it does NOT
cache
                           // the thumbnail
 IEIFLAG_ASPECT    = $004; // passed to the extractor to beg it to render
to
                           // the aspect ratio of the supplied rect
 IEIFLAG_OFFLINE   = $008; // if the extractor shouldn't hit the net to get
                           // any content needs for the rendering
 IEIFLAG_GLEAM     = $010; // does the image have a gleam? this will be
                           // returned if it does
 IEIFLAG_SCREEN    = $020; // render as if for the screen  (this is
exlusive
                           // with IEIFLAG_ASPECT )
 IEIFLAG_ORIGSIZE  = $040; // render to the approx size passed, but crop if
                           // neccessary
 IEIFLAG_NOSTAMP   = $080; // returned from the extractor if it does NOT
want
                           // an icon stamp on the thumbnail
 IEIFLAG_NOBORDER  = $100; // returned from the extractor if it does NOT
want
                           // an a border around the thumbnail
 IEIFLAG_QUALITY   = $200; // passed to the Extract method to indicate that
                           // a slower, higher quality image is desired,
                           // re-compute the thumbnail

{$IFDEF DELPHI3}
// Delphi 3 SysUtils does not have this function
function ExcludeTrailingBackslash(const Src: string): string;
{$ENDIF}

// IShellFolder methods helper
procedure ShellFolderBindToObject(const ShellFolder: IShellFolder;
 PIDL: PItemIDList; const riid: TGUID; out pv);
function ShellFolderGetUIObjectOf(const ShellFolder: IShellFolder;
 cidl: DWORD; var PIDL: PItemIDList; riid: TGUID; out pv): Boolean;
procedure ShellFolderParseDisplayName(const ShellFolder: IShellFolder;
 const DisplayName: string; out PIDL: PItemIDList);
function ShellFolderGetExtractImage(const ShellFolder: IShellFolder;
 const RelativeFileName: string; Malloc: IMalloc;
 out XtractImage: IExtractImage): Boolean;

function GetExtractImageItfPtr(const FileName: string;
 out XtractImage: IExtractImage): Boolean;
function GetFileLargeIcon(const FileName: string;
 out LargeIcon: TIcon): Boolean;
function ExtractImageGetFileThumbnail(const XtractImage: IExtractImage;
 ImgWidth, ImgHeight, ImgColorDepth: Integer; var Flags: DWORD; Bmp:
TBitmap;
 out RunnableTask: IRunnableTask): Boolean;
function GetSysImgListIndex(const FileName: string): Integer;
procedure GetShellFolderItfPtr(const FolderName: string; Malloc: IMalloc;
 out TargetFolder: IShellFolder);
function GetBitmapFromFile(const FileName: String): TGraphic;

implementation

uses SysUtils, ComObj;

{$IFDEF DELPHI3}
function ExcludeTrailingBackslash(const Src: string): string;
begin
 Result := Src;
 if AnsiLastChar(Result) = '\' then
   SetLength(Result, Pred(Length(Result)));
end;
{$ENDIF DELPHI3}

procedure ShellFolderBindToObject(const ShellFolder: IShellFolder;
 PIDL: PItemIDList; const riid: TGUID; out pv);
begin
 OleCheck(ShellFolder.BindToObject(PIDL, nil, riid,
   {$IFDEF DELPHI3}Pointer(pv){$ELSE}pv{$ENDIF}));
end;

function ShellFolderGetUIObjectOf(const ShellFolder: IShellFolder;
 cidl: DWORD; var PIDL: PItemIDList; riid: TGUID; out pv): Boolean;
begin
 Result := NOERROR = ShellFolder.GetUIObjectOf(0, cidl, PIDL,
   riid, nil, {$IFDEF DELPHI3}Pointer(pv){$ELSE}pv{$ENDIF});
end;

procedure ShellFolderParseDisplayName(const ShellFolder: IShellFolder;
 const DisplayName: string; out PIDL: PItemIDList);
var
 Attributes, Eaten: DWORD;
begin
 OleCheck(ShellFolder.ParseDisplayName(0, nil,
   PWideChar(WideString(DisplayName)), Eaten, PIDL, Attributes));
end;

function ShellFolderGetExtractImage(const ShellFolder: IShellFolder;
 const RelativeFileName: string; Malloc: IMalloc;
 out XtractImage: IExtractImage): Boolean;
var
 PIDL: PItemIDList;
begin
 ShellFolderParseDisplayName(ShellFolder, RelativeFileName, PIDL);
 Result := ShellFolderGetUIObjectOf(ShellFolder, 1, PIDL,
   IExtractImage, XtractImage);
 Malloc.Free(PIDL);
end;

function GetExtractImageItfPtr(const FileName: string;
 out XtractImage: IExtractImage): Boolean;
var
 TargetFolder: IShellFolder;
 FilePath: string;
 ItemIDList: PItemIDList;
 Malloc: IMalloc;
begin
 FilePath := ExcludeTrailingBackslash(ExtractFilePath(FileName));
 OleCheck(SHGetMalloc(Malloc));
 GetShellFolderItfPtr(FilePath, Malloc, TargetFolder);
 ShellFolderParseDisplayName(TargetFolder, ExtractFileName(FileName),
   ItemIDList);
 try
   Result := ShellFolderGetUIObjectOf(TargetFolder, 1, ItemIDList,
     IExtractImage, XtractImage);
 finally
   Malloc.Free(ItemIDList);
 end;
end;

function GetFileLargeIcon(const FileName: string; out LargeIcon: TIcon):
Boolean;
var
 SFI: TSHFileInfo;
begin
 if 0 <> SHGetFileInfo(PChar(FileName), FILE_ATTRIBUTE_ARCHIVE, SFI,
   sizeof(SFI), SHGFI_ICON or SHGFI_LARGEICON) then
 begin
   LargeIcon := TIcon.Create;
   LargeIcon.Handle := SFI.hIcon;
   Result := True;
 end else
   Result := False;
end;

function ExtractImageGetFileThumbnail(const XtractImage: IExtractImage;
 ImgWidth, ImgHeight, ImgColorDepth: Integer; var Flags: DWORD; Bmp:
TBitmap;
 out RunnableTask: IRunnableTask): Boolean;
var
 Size: TSize;
 Buf: array[0..MAX_PATH] of WideChar;
 BmpHandle: HBITMAP;
 Priority: DWORD;
 GetLocationRes: HRESULT;

 procedure FreeAndNilBitmap;
 begin
   {$IFNDEF DELPHI3}
   FreeAndNil(Bmp);
   {$ELSE}
   Bmp.Free;
   Bmp := nil;
   {$ENDIF}
 end;

begin
 Result := False;
 RunnableTask := nil;
 Size.cx := ImgWidth;
 Size.cy := ImgHeight;
 Priority := IEIT_PRIORITY_NORMAL;
 Flags := Flags or IEIFLAG_ASYNC;
 GetLocationRes := XtractImage.GetLocation(Buf, sizeof(Buf), Priority,
Size,
   ImgColorDepth, Flags);

 if (GetLocationRes = NOERROR) or (GetLocationRes = E_PENDING) then
 begin
   if GetLocationRes = E_PENDING then
   begin
     { if QI for IRunnableTask succeed, we can use RunnableTask
       interface pointer later to kill running extraction process.
       We could spawn a new thread here to extract image. }
     if S_OK <> XtractImage.QueryInterface(IRunnableTask, RunnableTask)
then
       RunnableTask := nil;
   end;

   try
     OleCheck(XtractImage.Extract(BmpHandle)); // This could consume a long
time.
                                               // If RunnableTask is
available
                                               // then calling Kill()
method
                                               // will immediately abort
the process.
     Bmp.Handle := BmpHandle;
     Result := True;
   except
     on E: EOleSysError do
     begin
//        -------------
       OutputDebugString(PChar(string(E.ClassName) + ': ' + E.Message));
//        -------------
       FreeAndNilBitmap;
       Result := False;
     end
     else
     begin
       FreeAndNilBitmap;
       raise;
     end;
   end; { try/except }
 end;
end;

function GetSysImgListIndex(const FileName: string): Integer;
var
 SFI: TSHFileInfo;
begin
 SHGetFileInfo(PChar(FileName), 0, SFI, sizeof(TSHFileInfo),
   SHGFI_SYSICONINDEX);
 Result := SFI.iIcon;
end;

procedure GetShellFolderItfPtr(const FolderName: string; Malloc: IMalloc;
 out TargetFolder: IShellFolder);
var
 DesktopFolder: IShellFolder;
 ItemIDList: PItemIDList;
begin
 OleCheck(SHGetDesktopFolder(DesktopFolder));
 ShellFolderParseDisplayName(DesktopFolder, FolderName, ItemIDList);
 try
   ShellFolderBindToObject(DesktopFolder, ItemIDList, IShellFolder,
TargetFolder);
 finally
   Malloc.Free(ItemIDList);
 end;
end;

//*******************************************************

function GetBitmapFromFile(const FileName: String): TGraphic;
var
 XtractImage: IExtractImage;
 Bmp: TBitmap;
 Icon: TIcon;
 ColorDepth: Integer;
 Flags: DWORD;
 RT: IRunnableTask;
begin
 Flags := DWORD(IEIFLAG_OFFLINE) or DWORD(IEIFLAG_SCREEN);
 ColorDepth := 32;

 Result := nil;
 Icon := nil;
 Bmp := TBitmap.Create;
 try
   if GetFileLargeIcon(FileName, Icon) then
     Result := Icon;

   if GetExtractImageItfPtr(FileName, XTractImage) and
//       (not AnsiEndsStr('.dwg', FileName)) and
      ExtractImageGetFileThumbnail(XtractImage, 256, 256, ColorDepth,
Flags, Bmp, RT) then
   begin
     Result := Bmp;
     Icon.Free;
   end
   else
     Bmp.Free;
 except
 end;
end;

end.

{-------------------------------------------------------------------------------
Unit Name: ShellObjHelper
Author   : hans gulo (HG)
Purpose  : Shell Object helper routines
Purpose  : Demo application's main unit for retrieving IExtractImage
interface
           pointer from Windows Shell folder to crete thumbnail image.
           This code is a complementary for Delphi3000.com article at
           http://www.delphi3000.com/articles/article_3806.asp
-------------------------------------------------------------------------------}