Mega Code Archive
Implementing IExtractImage
<![CDATA[
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
]]>