Multithreaded File Preview (Lazarus + WinAPI) - multithreading

Question

Hello all,
i am having problems getting the file preview (the one shown on the right side in the Windows Explorer window) for a certain file.
So far fetching the file preview works fine, but it takes a long time (between 0.5 and 2 seconds). Thus i do not want it to be executed in the main thread (as this would interrupt the program gui).
I tried to execute the file preview extraction in a worker thread, but this yields a SIGSEGV.
The call stack is also not really useful, it only shows that the exception is raised in ShellObjHelper in Line 141 (see source code below).
Source Code for main unit:
type
TThreadedImageInfo = record
fileName: String;
width: integer;
height: integer;
icon: TIcon;
image: TImage;
bmp: TBitmap;
infoOut: String;
memo: TMemo;
end;
PThreadedImageInfo = ^TThreadedImageInfo;
procedure loadThumbnailImageFromFile(aData: Pointer);
var
XtractImage: IExtractImage;
ColorDepth: integer;
Flags: DWORD;
RT: IRunnableTask;
FileName: string;
pThreadInfo: PThreadedImageInfo;
begin
pThreadInfo := PThreadedImageInfo(aData);
if assigned(pThreadInfo) then begin
FileName := pThreadInfo^.fileName;
ColorDepth := 32;
Flags := IEIFLAG_ASPECT or IEIFLAG_QUALITY or IEIFLAG_ORIGSIZE; // = 580
if FileExists(FileName) then begin
if GetExtractImageItfPtr(FileName, XTractImage) then begin
if ExtractImageGetFileThumbnail(XtractImage, pthreadinfo^.Image.Width,
pthreadinfo^.Image.Height, ColorDepth, Flags, RT, pthreadinfo^.Bmp) then begin
if (Flags and IEIFLAG_CACHE) <> 0 then
pThreadInfo^.infoOut := pThreadInfo^.infoOut + 'Extractor does not cache the thumbnail.' + #13;
if (Flags and IEIFLAG_GLEAM) <> 0 then
pThreadInfo^.infoOut := pThreadInfo^.infoOut + 'The image has a gleam.' + #13;
if (Flags and IEIFLAG_NOSTAMP) <> 0 then
pThreadInfo^.infoOut := pThreadInfo^.infoOut + 'Extractor does not want an icon stamp on the thumbnail.' + #13;
if (Flags and IEIFLAG_NOBORDER) <> 0 then
pThreadInfo^.infoOut := pThreadInfo^.infoOut + 'Extractor does not want an a border around the thumbnail.' + #13;
end else if GetFileLargeIcon(FileName, pThreadInfo^.icon) then begin
pThreadInfo^.infoOut := 'Thumbnail is not available. Default icon displayed.';
end;
end else begin
pThreadInfo^.infoOut := 'Error loading IExtractImage.';
end;
end else begin
pThreadInfo^.infoOut := 'Error: File does not exist.';
end;
end;
end;
procedure threadDone(Sender: TObject; aData: Pointer);
var
pThreadInfo: PThreadedImageInfo;
begin
pthreadInfo := PThreadedImageInfo(aData);
if assigned(pThreadInfo) then begin
if assigned(pthreadInfo^.Bmp) then begin
pthreadinfo^.Image.Picture.Assign(pthreadInfo^.Bmp);
end else if assigned(pthreadInfo^.icon) then begin
pthreadinfo^.Image.Picture.Assign(pthreadInfo^.icon);
end else begin
pThreadInfo^.Image.Picture.Assign(nil);
end;
if assigned(pThreadInfo^.memo) then
pThreadInfo^.memo.Lines.Text := pThreadInfo^.infoOut;
if assigned(pthreadInfo^.icon) then
pthreadInfo^.icon.free();
if assigned(pthreadInfo^.bmp) then
pthreadInfo^.bmp.free();
end;
dispose(pthreadinfo);
end;
procedure TForm1.Button1Click(Sender: TObject);
var
pThreadInfo: PThreadedImageInfo;
begin
new(pThreadInfo);
pThreadInfo^.fileName := Edit1.Text;
pThreadInfo^.image := Image1;
pThreadInfo^.memo := Memo1;
pThreadInfo^.icon := nil;
pThreadInfo^.bmp := nil;
pThreadInfo^.infoOut := '';
// use worker thread:
//TThread.ExecuteInThread(#loadThumbnailImageFromFile, pThreadInfo, #threadDone);
// use main thread:
loadThumbnailImageFromFile(pThreadInfo);
threadDone(nil, pThreadInfo);
end;
Source code for helper unit:
unit ShellObjHelper;
{$MODE objfpc}{$H+}
{$IFDEF VER100}{$DEFINE DELPHI3}{$ENDIF}
interface
uses
Windows, ShlObj, ActiveX, ShellAPI, Graphics, SysUtils, ComObj;
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
// 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 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; out RunnableTask: IRunnableTask; out Bmp: TBitmap): Boolean;
procedure GetShellFolderItfPtr(const FolderName: string; Malloc: IMalloc; out TargetFolder: IShellFolder);
implementation
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 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
result := SHGetFileInfo(PChar(FileName), FILE_ATTRIBUTE_ARCHIVE, SFI, sizeof(SFI), SHGFI_ICON or SHGFI_LARGEICON) <> 0;
if result then begin
LargeIcon := TIcon.Create;
LargeIcon.Handle := SFI.hIcon;
end;
end;
function ExtractImageGetFileThumbnail(const XtractImage: IExtractImage; ImgWidth, ImgHeight, ImgColorDepth: Integer;
var Flags: DWORD; out RunnableTask: IRunnableTask; out Bmp: TBitmap): 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;
////////////////////////// EXCEPTION HERE, but only when multithreading /////////////////////////////////////////////////////
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;
Bmp := TBitmap.Create;
try
// This could consume a long time.
// If RunnableTask is available then calling Kill() method will immediately abort the process.
OleCheck(XtractImage.Extract(BmpHandle));
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;
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;
end.
The actual question(s):
Why is the image extraction working without multithreading, but failing when using a worker thread?
How can i make this work?
I already started studying this post for another solution, but i am not yet sure how to do this.
Useful Informations:
Source for helper unit code: How to retrieve the file previews used by windows explorer in Windows vista and seven?
Multithreading example: https://lazarus-ccr.sourceforge.io/docs/rtl/classes/tthread.executeinthread.html
Activating PDF preview: open Adobe Acrobat Reader -> Edit -> Preferences -> General -> check "Enable PDF thumbnail previews"
I am using Lazarus v2.0.10 r63526 on Windows 10 Pro 64 bit.

Answer 1

Thanks to the comment from #IInspectable, that's the hint i needed.
Solution:
Add CoInitialize before calling GetExtractImageItfPtr and add CoUninitialize after receiving the file preview, but still within the worker thread.
Ensure that CoUninitialize is called even if exceptions occur by using try and finally`.
Working source code for main unit with worker thread:
type
TThreadedImageInfo = record
fileName: String;
width: integer;
height: integer;
icon: TIcon;
image: TImage;
bmp: TBitmap;
infoOut: String;
memo: TMemo;
end;
PThreadedImageInfo = ^TThreadedImageInfo;
procedure loadThumbnailImageFromFile(aData: Pointer);
var
XtractImage: IExtractImage;
ColorDepth: integer;
Flags: DWORD;
RT: IRunnableTask;
FileName: string;
pThreadInfo: PThreadedImageInfo;
begin
pThreadInfo := PThreadedImageInfo(aData);
if assigned(pThreadInfo) then begin
FileName := pThreadInfo^.fileName;
ColorDepth := 32;
Flags := IEIFLAG_ASPECT or IEIFLAG_QUALITY or IEIFLAG_ORIGSIZE; // = 580
if FileExists(FileName) then begin
CoInitialize(nil);
try
if GetExtractImageItfPtr(FileName, XTractImage) then begin
if ExtractImageGetFileThumbnail(XtractImage, pthreadinfo^.Image.Width,
pthreadinfo^.Image.Height, ColorDepth, Flags, RT, pthreadinfo^.Bmp) then begin
if (Flags and IEIFLAG_CACHE) <> 0 then
pThreadInfo^.infoOut := pThreadInfo^.infoOut + 'Extractor does not cache the thumbnail.' + #13;
if (Flags and IEIFLAG_GLEAM) <> 0 then
pThreadInfo^.infoOut := pThreadInfo^.infoOut + 'The image has a gleam.' + #13;
if (Flags and IEIFLAG_NOSTAMP) <> 0 then
pThreadInfo^.infoOut := pThreadInfo^.infoOut + 'Extractor does not want an icon stamp on the thumbnail.' + #13;
if (Flags and IEIFLAG_NOBORDER) <> 0 then
pThreadInfo^.infoOut := pThreadInfo^.infoOut + 'Extractor does not want an a border around the thumbnail.' + #13;
end else if GetFileLargeIcon(FileName, pThreadInfo^.icon) then begin
pThreadInfo^.infoOut := 'Thumbnail is not available. Default icon displayed.';
end;
end else begin
pThreadInfo^.infoOut := 'Error loading IExtractImage.';
end;
finally
CoUninitialize;
end;
end else begin
pThreadInfo^.infoOut := 'Error: File does not exist.';
end;
end;
end;
procedure threadDone(Sender: TObject; aData: Pointer);
var
pThreadInfo: PThreadedImageInfo;
begin
pthreadInfo := PThreadedImageInfo(aData);
if assigned(pThreadInfo) then begin
if assigned(pthreadInfo^.Bmp) then begin
pthreadinfo^.Image.Picture.Assign(pthreadInfo^.Bmp);
end else if assigned(pthreadInfo^.icon) then begin
pthreadinfo^.Image.Picture.Assign(pthreadInfo^.icon);
end else begin
pThreadInfo^.Image.Picture.Assign(nil);
end;
if assigned(pThreadInfo^.memo) then
pThreadInfo^.memo.Lines.Text := pThreadInfo^.infoOut;
if assigned(pthreadInfo^.icon) then
pthreadInfo^.icon.free();
if assigned(pthreadInfo^.bmp) then
pthreadInfo^.bmp.free();
end;
dispose(pthreadinfo);
end;
procedure TForm1.Button1Click(Sender: TObject);
var
pThreadInfo: PThreadedImageInfo;
begin
new(pThreadInfo);
pThreadInfo^.fileName := Edit1.Text;
pThreadInfo^.image := Image1;
pThreadInfo^.memo := Memo1;
pThreadInfo^.icon := nil;
pThreadInfo^.bmp := nil;
pThreadInfo^.infoOut := '';
TThread.ExecuteInThread(#loadThumbnailImageFromFile, pThreadInfo, #threadDone);
end;