Implementing-IExtractImage


            Title: Implementing IExtractImage
Question: Implement IExtractImage so that the shell provides a preview of a file type to the shell
Answer:
Whenever you use the thumbnail view in the shell, the shell will display a small preview of the file; in order to produce the preview the shell uses the IExtractImage interface wich is declared as follows:
 
 IExtractImage = interface(IUnknown)
 ['{BB2E617C-0920-11d1-9A0B-00C04FC2D6C1}']
 function GetLocation(Buffer: PWideChar; BufferSize: DWORD;
 Priority: PDWORD; const Size: TSize;
 ColorDepth: DWORD; Flags: PDWORD ): HResult; stdcall;
 function Extract(var BmpImage: HBITMAP): HResult; stdcall;
 end;
 
 IExtractImage2 = interface(IExtractImage)
 ['{953BB1EE-93B4-11d1-98A3-00C04FB687DA}']
 function GetDateStamp(var DateStamp : TFILETIME) : hresult; stdcall;
 end;
 
Source: http://www.whirlingdervishes.com/nselib/delphi/samples/source.php 
 
In order to implement IExtractImage you need to implement IPersistFile, IExtractImage2 is implemented if you are going to use the shell built-in cache features, more on that later
 
Lets begin the with a simple yet, open IExtractImage implementation:
 
unit Thumbnails;
 
{$WARN SYMBOL_PLATFORM OFF}
 
interface
 
uses
 Windows, ActiveX, Classes, ComObj, cbTools, Graphics;
 
type
 TCustomThumbnail = class(TComObject, IPersist, IPersistFile, IExtractImage)
 private
 FFileName: String;
 FFileError: Boolean;
 FPic: TPicture;
 
 function GetIsEnabled: Boolean; virtual;
 function GetWorkOnDisc: Boolean;
 function GetWorkOnRemote: Boolean;
 function GetIsFileLocked: Boolean;
 function GetThumbError: String;
 protected
 procedure LogWrite(const Data: String; Level: TLoggerLevel); virtual; abstract;
 procedure ExtractThumb; virtual; abstract;
 {IPersistFile}
 function GetClassID(out classID: TGUID): HRESULT; stdcall;
 function GetCurFile(out pszFileName: PWideChar): HRESULT; stdcall;
 function IsDirty: HRESULT; stdcall;
 function Load(pszFileName: PWideChar; dwMode: Integer): HRESULT; stdcall;
 function Save(pszFileName: PWideChar; fRemember: LongBool): HRESULT; stdcall;
 function SaveCompleted(pszFileName: PWideChar): HRESULT; stdcall;
 {IExtractImage}
 function Extract(var BmpImage: HBITMAP): HRESULT; stdcall;
 function GetLocation(Buffer: PWideChar; BufferSize: Cardinal;
 Priority: PDWORD; const Size: TSIZE; ColorDepth: Cardinal;
 Flags: PDWORD): HRESULT; stdcall;
 public
 property Enabled: Boolean read GetIsEnabled;
 property OnDisc: Boolean read GetWorkOnDisc;
 property OnRemote: Boolean read GetWorkOnRemote;
 property FileName: String read FFileName;
 property FileLocked: Boolean read GetIsFileLocked;
 property Error: Boolean read FFileError write FFileError;
 property ErrorThumb: String read GetThumbError;
 property Picture: TPicture read FPic;
 end;
 
 
implementation
 
uses ComServ, GraphicEx, SysUtils;
 
function IsInCD(Const FileName: String; Flags: Cardinal): Boolean;
begin
 Result := GetDriveType( PChar( ExtractFileDrive( FileName ) ) ) = Flags;
end;
 
procedure MakeThumbnail(Image: TPicture; SizeX, SizeY: Integer);
var
 ABitmap: Graphics.TBitmap;
begin
 ABitmap := Graphics.TBitmap.Create;
 
 if not (Image.Graphic is Graphics.TBitmap) then
 begin
 with ABitmap do
 begin
 PixelFormat := pf24Bit;
 Width := Image.Width;
 Height := Image.Height;
 Canvas.Draw(0, 0, Image.Graphic);
 end;
 Image.Bitmap.Assign( ABitmap );
 end;
 
 ABitmap.PixelFormat := pf24bit;
 ABitmap.Width := SizeX;
 ABitmap.Height := SizeY;
 ABitmap.Palette := Image.Bitmap.Palette;
 
 SetStretchBltMode(ABitmap.Canvas.Handle, COLORONCOLOR);
 StretchBlt(ABitmap.Canvas.Handle, 0, 0, SizeX, SizeY, Image.Bitmap.Canvas.Handle, 0, 0,
 Image.Bitmap.Width, Image.Bitmap.Height, SRCCOPY);
 Image.Bitmap.Assign( ABitmap );
 
 ABitmap.Free;
end;
 
 
{ TCustomThumbnail }
 
function TCustomThumbnail.GetThumbError: String;
begin
 Result := '';
end;
 
function TCustomThumbnail.GetIsEnabled: Boolean;
begin
 Result := False;
end;
 
function TCustomThumbnail.GetIsFileLocked: Boolean;
var
 hFile: THandle;
begin
 hFile := CreateFile ( PChar(FFileName), GENERIC_READ, FILE_SHARE_READ, nil,
 OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0 );
 Result := hFile = INVALID_HANDLE_VALUE;
 CloseHandle( hFile );
end;
 
function TCustomThumbnail.GetWorkOnDisc: Boolean;
begin
 Result := True;
end;
 
function TCustomThumbnail.GetWorkOnRemote: Boolean;
begin
 Result := True;
end;
 
function TCustomThumbnail.GetLocation(Buffer: PWideChar; BufferSize: Cardinal;
 Priority: PDWORD; const Size: TSIZE; ColorDepth: Cardinal; Flags: PDWORD): HRESULT;
var
 Tmp: String;
begin
 if (Prioritynil) then
 Priority^:=IEI_PRIORITY_NORMAL;
 
 Result := NOERROR;
 if (Flagsnil) then //more on flags later
 begin
 if (Flags^ and IEIFLAG_ASYNC) 0 then
 Result := E_PENDING;
 Flags^ := Flags^ + IEIFLAG_CACHE + IEIFLAG_REFRESH;
 end;
 
 FPic := TPicture.Create;
 if not FFileError then
 ExtractThumb;
 
 if FFileError then
 begin
 Tmp := GetThumbError;
 if FileExists( Tmp ) then
 begin
 try
 FPic.Graphic.LoadFromFile( Tmp );
 except
 FPic.Free;
 FPic := nil;
 Result := E_FAIL;
 end;
 end else begin
 Result := E_FAIL;
 Exit;
 end;
 end;
 
 if Assigned( FPic ) then
 MakeThumbnail( FPic, Size.cx, Size.cy );
end;
 
function TCustomThumbnail.Extract(var BmpImage: HBITMAP): HRESULT;
begin
 try
 BmpImage := CopyImage(FPic.Bitmap.Handle, IMAGE_BITMAP, 0,0,0);
 Result := S_OK;
 finally
 if Assigned( FPic ) then
 FPic.Free;
 FPic := nil;
 end;
end;
 
function TCustomThumbnail.GetClassID(out classID: TGUID): HRESULT;
begin
 Result := E_NOTIMPL;
end;
 
function TCustomThumbnail.GetCurFile(out pszFileName: PWideChar): HRESULT;
begin
 Result := E_NOTIMPL;
end;
 
function TCustomThumbnail.IsDirty: HRESULT;
begin
 Result := E_NOTIMPL;
end;
 
function TCustomThumbnail.Load(pszFileName: PWideChar; dwMode: Integer): HRESULT;
begin
 FFileName := pszFileName;
 Result := S_OK;
 
 FFileError := GetIsFileLocked;
 
 if not Enabled then
 begin
 Result := E_FAIL;
 Exit;
 end;
 
 if IsInCD( FFileName, DRIVE_CDROM ) then
 begin
 if GetWorkOnDisc then
 begin
 Result := E_FAIL;
 Exit;
 end;
 end;
 
 if IsInCD( FFileName, DRIVE_REMOTE ) then
 begin
 if GetWorkOnRemote then
 begin
 Result := E_FAIL;
 Exit;
 end;
 end;
end;
 
function TCustomThumbnail.Save(pszFileName: PWideChar; fRemember: LongBool): HRESULT;
begin
 Result := E_NOTIMPL;
end;
 
function TCustomThumbnail.SaveCompleted(pszFileName: PWideChar): HRESULT;
begin
 Result := E_NOTIMPL;
end;
 
end.
 
As you see IPersistFile.Load is the only method of IPersistFile wich needs implementation, so a very basic implementation is used, also note that in order to compile you will need graphicex library by mike lischke (at http://delphi-gems.com/) 
 
Now on the IExtractImage.GetLocation method flags, those flags can be:
 
Const
 IEIFLAG_ASYNC = $0001; 
 IEIFLAG_CACHE = $0002; 
 IEIFLAG_ASPECT = $0004; 
 IEIFLAG_OFFLINE = $0008; 
 IEIFLAG_GLEAM = $0010; 
 IEIFLAG_SCREEN = $0020; 
 IEIFLAG_ORIGSIZE = $0040; 
 IEIFLAG_NOSTAMP = $0080; 
 IEIFLAG_NOBORDER = $0100; 
 IEIFLAG_QUALITY = $0200; 
 IEIFLAG_REFRESH = $0400; 
 
IEIFLAG_ASYNC is set if the object is free-threaded or the extraction is performed in the background, if the extension is supports that, it should result E_PENDING in GetLocation
 
IEIFLAG_CACHE is set if you desire to let the shell cache the resulting images, if you set this flag, it is recommended that you provide IExtractImage2 interface so that the shell can tell when the thumbnail last was updated
 
IEIFLAG_REFRESH is set if you desire the shell to provide a Refresh thumbnail option 
 
IEIFLAG_OFFLINE is set to indicate that internet explorer should not connect if there are remote items
 
More on the flags can be obtained on MSDN
 
Also note that I have provided a empty extension, fill it to preview images of any type, also note that the shell is instructed to cache the images however it will not check the cache since we arent implementing IExtractImage2 in order to register the extension you will need a class factory such as the following:
 
type
 TThumbnailFactory = class( TComObjectFactory )
 public
 procedure UpdateRegistry(Register: Boolean); override;
 end;
 
{ TCBZThumbnailFactory }
 
procedure RegisterWin32NT(Const ClassID, Description: String; Register: Boolean);
begin
 if (Win32Platform = VER_PLATFORM_WIN32_NT) then
 with TRegistry.Create do
 try
 RootKey := HKEY_LOCAL_MACHINE;
 OpenKey('SOFTWARE\Microsoft\Windows\CurrentVersion\Shell Extensions', True);
 OpenKey('Approved', True);
 if Register then
 WriteString(ClassID, Description)
 else
 DeleteValue(ClassID)
 finally
 Free;
 end;
end;
 
procedure TCBRThumbnailFactory.UpdateRegistry(Register: Boolean);
var
 ClassID: String;
begin
 ClassID := GUIDToString( Class_CBRThumbnails );
 if Register then
 begin
 inherited UpdateRegistry( Register );
 CreateRegKey('EXTENSION\shellex\{BB2E617C-0920-11d1-9A0B-00C04FC2D6C1}','',
 ClassID);
 RegisterWin32NT(ClassID, Description, Register);
 end else begin
 DeleteRegKey('EXTENSION\shellex\{BB2E617C-0920-11d1-9A0B-00C04FC2D6C1}');
 RegisterWin32NT( ClassID, Description, Register);
 inherited UpdateRegistry( Register )
 end;
end;
 
Where EXTENSION is the file extension you are desire to preview
Graphic Delphi
