(* ImageEn Build 7.0.0.06.2637 @ 7-4-17 14:58:42.679 *) (* Copyright (c) 1998-2017 by Carlotta Calandra. All rights reserved. Copyright (c) 2011-2017 by Xequte Software. This software comes without express or implied warranty. In no case shall the author be liable for any damage or unwanted behavior of any computer hardware and/or software. Author grants you the right to include the component in your application, whether COMMERCIAL, SHAREWARE, or FREEWARE. ImageEn, IEvolution and ImageEn ActiveX may not be included in any commercial, shareware or freeware libraries or components. www.ImageEn.com *) (* File: iexShellThumbnails.pas Description: Retrieve thumbnails from Windows (as displayed in Explorer) File version: 1004 Notes: - Define VIDEO_THUMBNAILS in ie.inc to allow ImageEn to display thumbnails for videos in TImageEnMView *) unit iexShellThumbnails; interface uses Windows, SysUtils, Graphics, iexBitmaps, Forms; {$I ie.inc} {$IFDEF VIDEO_THUMBNAILS} type {$EXTERNALSYM SIIGBF} SIIGBF = Integer; {$EXTERNALSYM IShellItemImageFactory} IShellItemImageFactory = interface(IUnknown) ['{BCC18B79-BA16-442F-80C4-8A59C30C463B}'] function GetImage(size: TSize; flags: SIIGBF; out phbm: HBITMAP): HRESULT; stdcall; end; const SIIGBF_RESIZETOFIT = $00000000; SIIGBF_BIGGERSIZEOK = $00000001; SIIGBF_MEMORYONLY = $00000002; SIIGBF_ICONONLY = $00000004; SIIGBF_THUMBNAILONLY = $00000008; SIIGBF_INCACHEONLY = $00000010; IID_IExtractImage2: TGUID = '{953BB1EE-93B4-11D1-98A3-00C04FB687DA}'; Min_Thumbnail_Size = 52; Max_Thumbnail_Size = 256; 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 type {$HPPEMIT 'DECLARE_DINTERFACE_TYPE_UUID("953BB1EE-93B4-11D1-98A3-00C04FB687DA", IExtractImage2)'} 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; IExtractImage = interface ['{BB2E617C-0920-11d1-9A0B-00C04FC2D6C1}'] function GetLocation(pszwPathBuffer: PWideChar; cch: DWord; var dwPriority: DWord; var rgSize: TSize; dwRecClrDepth: DWord; var dwFlags: DWord): HResult; stdcall; function Extract(var hBmpThumb: HBITMAP): HResult; stdcall; end; IExtractImage2 = interface(IExtractImage) ['{953BB1EE-93B4-11D1-98A3-00C04FB687DA}'] function GetDateStamp(var pDateStamp: TFileTime): HResult; stdcall; end; {$ENDIF} {$IFDEF VIDEO_THUMBNAILS} // Retrieve the Windows thumnail for the specified file into a bitmap // Result is true if it succeeds function ExtractExplorerThumbnail(const sFileName : string; Bitmap : TBitmap; iWidth : Integer = 120; iHeight : Integer = 120; bWantTransparency: Boolean = False) : Boolean; overload; function ExtractExplorerThumbnail(const sFileName : string; IEBitmap : TIEBitmap; iWidth : Integer = 120; iHeight : Integer = 120; bWantTransparency: Boolean = False) : Boolean; overload; {$ENDIF} // Returns true if the file has an extension listed in IEGlobalSettings().MViewExplorerThumbnailExts function UseThumbnailFromExplorer(const sFileName : string) : Boolean; {$IFDEF VIDEO_THUMBNAILS} // Return icons of larger size (48x28, 256x256, etc) using GetImageListSH() Procedure IEGetLargeFileIcon(const sFilename : String; var aIcon : TIcon; SHIL_FLAG : Cardinal); // Return 256x256 icon using GetImageListSH(SHIL_JUMBO). Note: File types without a large icon will return a much smaller one procedure IEGetJumboFileIcon(const sFilename : string; DestBitmap : TIEBitmap); {$ENDIF} {$IFDEF VIDEO_THUMBNAILS} // Get icon of "My Computer" ("This PC" on Windows 8 or newer). Result is name of "My Computer" function IEGetMyComputerIcon(DestBitmap : TIEBitmap) : string; // Get name of "My Computer" ("This PC" on Windows 8 or newer) function IEGetMyComputerName : string; {$endif} {$IFDEF VIDEO_THUMBNAILS} 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}'; {$ENDIF} implementation {$IFDEF VIDEO_THUMBNAILS} uses ShellApi, Commctrl, bmpfilt, hyieutils, ShlObj, ActiveX, ComObj, iesettings, hyiedefs, ImageEnProc; const Shell_32_Dll = 'shell32.dll'; var Shell32Lib: HModule; _SHGetImageList: function (iImageList: integer; const riid: TGUID; var ppv: Pointer): hResult; stdcall; SHJumboImageList : HIMAGELIST; {$IFNDEF Delphi2007orNewer} _SHCreateItemFromParsingName: function(pszPath: LPCWSTR; const pbc: IBindCtx; const riid: TIID; out ppv): HResult; stdcall; {$ENDIF} {$ENDIF} {$IFDEF VIDEO_THUMBNAILS} {$IFNDEF Delphi2007orNewer} // Delphi 7 lacks this function function SHCreateItemFromParsingName(pszPath: LPCWSTR; const pbc: IBindCtx; const riid: TIID; out ppv): HResult; begin if Assigned(_SHCreateItemFromParsingName) then Result := _SHCreateItemFromParsingName(pszPath, pbc, riid, ppv) else begin Shell32Lib := GetModuleHandle(Shell_32_Dll); Result := E_NOTIMPL; if Shell32Lib > 0 then begin _SHCreateItemFromParsingName := GetProcAddress(Shell32Lib, 'SHCreateItemFromParsingName'); if Assigned(_SHCreateItemFromParsingName) then Result := _SHCreateItemFromParsingName(pszPath, pbc, riid, ppv); end; end; end; {$ENDIF} {$ENDIF} // Returns true if the file has an extension listed in IEGlobalSettings().MViewExplorerThumbnailExts function UseThumbnailFromExplorer(const sFileName : string) : Boolean; begin {$IFDEF VIDEO_THUMBNAILS} Result := False; if (Win32Platform = VER_PLATFORM_WIN32_NT) and (Win32MajorVersion >= 5) then Result := IEFilenameInExtensions(sFileName, IEGlobalSettings().MViewExplorerThumbnailExts); {$ELSE} Result := False; {$ENDIF} end; {$IFDEF VIDEO_THUMBNAILS} function ExtractExplorerThumbnail(const sFileName : string; Bitmap : TBitmap; iWidth : Integer = 120; iHeight : Integer = 120; bWantTransparency: Boolean = False) : Boolean; var ImageFactory: IShellItemImageFactory; hRes: HResult; BmpHandle: HBITMAP; ExtractImage: IExtractImage; ExtractImage2: IExtractImage2; ASize: TSize; RunnableTask: IRunnableTask; ShellFolder, DesktopShellFolder: IShellFolder; PIDL: PItemIDList; Eaten: DWord; Attribute, Priority: DWord; TempFileName : Widestring; Flags: DWord; Colordepth: Cardinal; lRes: HResult; Buff: array [0 .. MAX_PATH * 4] of WideChar; begin Result := False; OleInitialize(nil); Try OleCheck(SHGetDesktopFolder(DesktopShellFolder)); OleCheck(DesktopShellFolder.ParseDisplayName(0, nil, StringToOleStr(ExtractFilePath(sFilename)), Eaten, PIDL, Attribute)); OleCheck(DesktopShellFolder.BindToObject(PIDL, nil, IID_IShellFolder, Pointer(ShellFolder))); CoTaskMemFree(PIDL); ASize.cx := iWidth; ASize.cy := iHeight; if IEIsWindowsVistaOrNewer then begin TempFileName := WideString(sFilename); hRes := SHCreateItemFromParsingName(PWideChar(TempFileName), nil, IShellItemImageFactory, ImageFactory); if Succeeded(hRes) then begin ASize.cx := iWidth; ASize.cy := iHeight; hRes := ImageFactory.GetImage(ASize, SIIGBF_THUMBNAILONLY, BmpHandle); if Succeeded(hRes) then begin if bWantTransparency then Bitmap.PixelFormat := pf32bit else Bitmap.PixelFormat := pf24bit; Bitmap.Handle := BmpHandle; Result := true; end; end; end else // XP begin OleCheck(ShellFolder.ParseDisplayName(0, nil, StringToOleStr(ExtractFileName(sFilename)), Eaten, PIDL, Attribute)); ShellFolder.GetUIObjectOf(0, 1, PIDL, IExtractImage, nil, ExtractImage); CoTaskMemFree(PIDL); if Assigned(ExtractImage) then begin if ExtractImage.QueryInterface(IID_IExtractImage2, Pointer(ExtractImage2)) = E_NOINTERFACE then ExtractImage2 := nil; RunnableTask := nil; Priority := 0; Flags := IEIFLAG_SCREEN or IEIFLAG_OFFLINE or IEIFLAG_ORIGSIZE or IEIFLAG_QUALITY; Colordepth := 32; lRes := ExtractImage.GetLocation(Buff, MAX_PATH, Priority, ASize, Colordepth, Flags); if (lRes = NOERROR) or (lRes = E_PENDING) then begin if lRes = E_PENDING then if ExtractImage.QueryInterface(IRunnableTask, RunnableTask) <> S_OK then RunnableTask := nil; if Succeeded(ExtractImage.Extract(BmpHandle)) then begin Bitmap.Handle := BmpHandle; Bitmap.PixelFormat := pf24bit; Result := True; end; end; end; end; except // UNEXPECTED ERROR end; OleUninitialize(); end; {$ENDIF} {$IFDEF VIDEO_THUMBNAILS} function ExtractExplorerThumbnail(const sFileName : string; IEBitmap : TIEBitmap; iWidth : Integer = 120; iHeight : Integer = 120; bWantTransparency: Boolean = False) : Boolean; var bmp : TBitmap; Row : PRGB32ROW; X, Y, InvY : Integer; begin Result := False; bmp := TBitmap.create; try if ExtractExplorerThumbnail(sFilename, bmp, iWidth, iHeight, True) then begin if bmp.PixelFormat <> pf32bit then IEBitmap.CopyFromTBitmap(bmp) else begin IEBitmap.Allocate( bmp.Width, bmp.Height, ie32RGB); // Get alpha and invert for Y := 0 to bmp.Height - 1 do begin Row := PRGB32ROW( bmp.Scanline[y] ); for X := 0 to bmp.Width - 1 do begin // Why do we need to invert the bitmap when it is pf32bit? TBitmap should already be handling bottom-up bitmaps??? InvY := bmp.Height - y - 1; IEBitmap.Pixels[ x, InvY ] := CreateRGB( Row[X].R, Row[X].G, Row[X].B ); IEBitmap.AlphaChannel.Pixels_ie8[ x, InvY ] := Row[X].A; end; end; end; Result := IEBitmap.Width > 10; end; finally bmp.free; end; end; {$ENDIF} {$IFDEF VIDEO_THUMBNAILS} function GetImageListSH(SHIL_FLAG : Cardinal): HIMAGELIST; begin Result := 0; if (Assigned(_SHGetImageList) = False) and (Win32Platform = VER_PLATFORM_WIN32_NT) then begin Shell32Lib := GetModuleHandle(Shell_32_Dll); if Shell32Lib > 0 then _SHGetImageList := GetProcAddress(Shell32Lib, PChar(727)); end; if Assigned(_SHGetImageList) then _SHGetImageList(SHIL_FLAG, IID_IImageList, Pointer(Result)); end; {$ENDIF} {$IFDEF VIDEO_THUMBNAILS} Procedure IEGetLargeFileIcon(const sFilename : String; var aIcon : TIcon; SHIL_FLAG : Cardinal); var aImgList : HIMAGELIST; SFI : TSHFileInfo; Begin // Get the index of the imagelist FillChar(SFI, SizeOf(TShFileInfo), 0); SHGetFileInfo(PChar(sFilename), FILE_ATTRIBUTE_NORMAL, SFI, SizeOf( TSHFileInfo ), SHGFI_ICON or SHGFI_LARGEICON); if not Assigned(aIcon) then aIcon := TIcon.Create; // Get the imagelist aImgList := GetImageListSH(SHIL_FLAG); // Extract the icon handle aIcon.Handle := ImageList_GetIcon(aImgList, SFI.iIcon, ILD_IMAGE); End; {$ENDIF} {$IFDEF VIDEO_THUMBNAILS} procedure IEGetJumboFileIcon(const sFilename : string; DestBitmap : TIEBitmap); var SFI : TSHFileInfo; icon : HIcon; Begin CoInitialize(nil); // Get the index of the imagelist FillChar(SFI, SizeOf(TShFileInfo), 0); SHGetFileInfo(PChar(sFilename), FILE_ATTRIBUTE_NORMAL, SFI, SizeOf( TSHFileInfo ), SHGFI_ICON or SHGFI_LARGEICON); // Get the imagelist if SHJumboImageList = 0 then SHJumboImageList := GetImageListSH(SHIL_JUMBO); // Extract the icon handle icon := ImageList_GetIcon(SHJumboImageList, SFI.iIcon, ILD_IMAGE); Try IEConvertIconToBitmap(icon, DestBitmap, True); except IEGetFileIcon(sFilename, DestBitmap); end; CoUninitialize; End; {$ENDIF} {$IFDEF VIDEO_THUMBNAILS} // Get icon of "My Computer" ("This PC" on Windows 8 or newer). Result is name of "My Computer" function IEGetMyComputerIcon(DestBitmap : TIEBitmap) : string; var SFI : TSHFileInfo; icon : HIcon; PIDL : PItemIDList; Begin // Get the index of the imagelist FillChar(SFI, SizeOf(TShFileInfo), 0); SHGetSpecialFolderLocation(Application.Handle, CSIDL_DRIVES, PIDL); SHGetFileInfo(PChar(PIDL), 0, SFI, SizeOf( TSHFileInfo ), SHGFI_PIDL or SHGFI_ICON or SHGFI_LARGEICON or SHGFI_DISPLAYNAME); Result := SFI.szDisplayName; if Result = '' then Result := 'This PC'; if DestBitmap <> nil then begin {$IFDEF VIDEO_THUMBNAILS} // Get the imagelist if SHJumboImageList = 0 then SHJumboImageList := GetImageListSH(SHIL_JUMBO); // Extract the icon handle icon := ImageList_GetIcon(SHJumboImageList, SFI.iIcon, ILD_IMAGE); Try IEConvertIconToBitmap(icon, DestBitmap, True); except // Fall back to low res icon IEConvertIconToBitmap(SFI.iIcon, DestBitmap); end; {$ELSE} IEConvertIconToBitmap(SFI.iIcon, DestBitmap); {$ENDIF} end; end; {$endif} {$IFDEF VIDEO_THUMBNAILS} // Get name of "My Computer" ("This PC" on Windows 8 or newer) function IEGetMyComputerName : string; begin Result := IEGetMyComputerIcon( nil ); end; {$endif} end.