问题描述
大家好，
我在获取某个文件的文件预览（Windows 资源管理器窗口右侧显示的预览）时遇到问题。
到目前为止，获取文件预览效果很好，但需要很长时间（在 0.5 到 2 秒之间）。因此我不希望它在主线程中执行（因为这会中断程序 gui）。
我尝试在工作线程中执行文件预览提取，但这会产生 SIGSEGV。
调用堆栈也不是很有用，它只显示在第 141 行的 ShellObjHelper 中引发了异常（请参阅下面的源代码）。
主机源代码：
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;
辅助单元的源代码：
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,{$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,PWideChar(WideString(displayName)),Eaten,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,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,IShellFolder,TargetFolder);
finally
Malloc.Free(ItemIDList);
end;
end;
end.
实际问题：
为什么图像提取在没有多线程的情况下工作，但在使用工作线程时失败？
我怎样才能做到这一点？
我已经开始研究 this post 以寻求另一种解决方案，但我还不确定如何去做。
有用信息：
辅助单元代码来源：How to retrieve the file previews used by windows explorer in Windows vista and seven?
多线程示例：https://lazarus-ccr.sourceforge.io/docs/rtl/classes/tthread.executeinthread.html
激活PDF预览：打开Adobe Acrobat Reader -> 编辑 -> 首选项 -> 常规 -> 勾选“启用 PDF 缩略图预览”
我在 Windows 10 Pro 64 位上使用 Lazarus v2.0.10 r63526。
解决方法
感谢@IInspectable 的评论，这就是我需要的提示。
解决方案：
在调用 CoInitialize 之前添加 GetExtractImageItfPtr 并在收到文件预览后添加 CoUninitialize，但仍在工作线程中。
使用 CoUninitialize 和 finally` 确保即使发生异常也会调用 try。
具有工作线程的主单元的工作源代码：
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;