多线程文件预览(Lazarus + WinAPI)

Question

大家好，

在获取某个文件的文件预览( Windows Explorer窗口右侧显示的文件预览)时，我遇到了问题。

到目前为止，获取文件预览很好，但是需要很长时间(从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, 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.

实际问题：

为什么映像提取不需要多线程，但在使用工作线程时却失败了？

我怎么才能把这事做好？

我已经开始研究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预览:打开->编辑-> Preferences -> General ->检查“启用PDF缩略图预览”

我在Windows10Pro 64位上使用Lazarusv2.0.10 r63526。

Answer 1

感谢@IInspectable的评论，这就是我需要的提示。

解决方案：

在调用CoInitialize之前添加GetExtractImageItfPtr，在收到文件预览后添加CoUninitialize，但仍然在辅助线程中。

确保调用CoUninitialize，即使使用try和finally` `出现异常。

具有工作线程的主单元的工作源代码：

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;