IExtractImage Delphi

Did you check the HRESULT return value of GetUIObjectOf?

If this method succeeds, it returns S_OK (0x00000000), otherwise, it returns an HRESULT error code.

HRESULT error codes

Here is the Source Code:

procedure PDFToJpg(Dir, FName: String);
  const
    IEIFLAG_ASPECT = 4;
    IEIFLAG_OFFLINE = 8;
    IEIFLAG_SCREEN = $20;
    IEIFLAG_ORIGSIZE = $40;

  var
    FolderISF, DesktopISF: IShellFolder;
    IExtractImg: IExtractImage;
    Attrib, Eaten: DWORD;
    pItemIDL: PItemIDList;
    MemAlloc: IMalloc;
    CharBuf: LPWSTR;
    hBmp: HBITMAP;
    Size1: TSize;
    Priority, Flags: Cardinal;
    GLResult: HResult;
    Size: Integer;
    WDir: PWideChar;
    WFName: PWideChar;
    Res: HRESULT;
  begin
    Size := (Length(Dir) + 1) * SizeOf(WideChar);
    WDir := CoTaskMemAlloc(Size);
    StringToWideChar(Dir, WDir, Size);

    Size := (Length(FName) + 1) * SizeOf(WideChar);
    WFName := CoTaskMemAlloc(Size);
    StringToWideChar(FName, WFName, Size);

    if not((Win32Platform = VER_PLATFORM_WIN32_NT) and (Win32MajorVersion >= 5)) then
    begin
      OKB('This is NOT avalible in systems older than Win 2000');
      Exit;
    end;

    if (SHGetMalloc(MemAlloc) <> NOERROR) or (MemAlloc = nil) then
      Exit;;
    // we need IMAlloc interface to free allocated memory of Shell
    if NOERROR = SHGetDesktopFolder(DesktopISF) then
    begin
      OleCheck(DesktopISF.ParseDisplayName(0, nil, WDir, Eaten,
        // place your Folder name here
        pItemIDL, Attrib));
      Delay(200);
      DesktopISF.BindToObject(pItemIDL, nil, IShellFolder, FolderISF);
      // you must free all of the allocated shell memory of pItemIDL
      MemAlloc.Free(pItemIDL);
      OleCheck(FolderISF.ParseDisplayName(0, nil, WFName, Eaten,
        // place your file name here
        pItemIDL, Attrib));
      Delay(200);
      Res := FolderISF.GetUIObjectOf(0, 1, pItemIDL, IExtractImage, nil, IExtractImg);
      MemAlloc.Free(pItemIDL);
      // set the size of the thumbnail with the Size1
      Size1.cx := 100; // thumbnail bitmap width
      Size1.cy := 100; // thumnbail bitmap height, before crop

      Flags := // IEIFLAG_SCREEN // does not crop off bitmap
        IEIFLAG_ORIGSIZE // crops extra area off. may not work in win 2000
        or IEIFLAG_OFFLINE; // no online search for unknown video codex

      Priority := 0; // not sure is this has any effect

      GLResult := IExtractImg.GetLocation(CharBuf, SizeOf(CharBuf), Priority, Size1, 32, Flags);
      if (GLResult = NOERROR) or (GLResult = E_PENDING) then
      begin
        try
          OleCheck(IExtractImg.Extract(hBmp));
          BMP1 := Tbitmap.Create;
          BMP1.Handle := hBmp;
          FName := FPA + 'Pictures\Q' + JobDefQuoNo.AsString + '\' + ChangeFileExt(FName, '.bmp');
          BMP1.SaveToFile(FName);
        finally
          if Assigned(BMP1) then
            BMP1.Free;
        end;
      end
      else
      begin
        try
          BMP1 := GetPathImage(ForceBSl(Dir) + FName);
          FName := FPA + 'Pictures\Q' + JobDefQuoNo.AsString + '\' + ChangeFileExt(FName, '.bmp');
          BMP1.SaveToFile(FName);
        finally
          if Assigned(BMP1) then
            BMP1.Free;
        end;
      end;
    end;
  end;

Res := FolderISF.GetUIObjectOf(0, 1, pItemIDL, IExtractImage, nil, IExtractImg);  =  -2147467263

-2147467263 (decimal) = 0x80004001(hex)
Seems that your Interface IExtractImage is not implemented

Have a look at this for further help...
Implementing IExtractImage
How to use the IExtractImage interface to get image...

I think ir is:

type
  IExtractImage = interface(IUnknown)
    [SID_IExtractImage]
    function GetLocation(pszPathBuffer: LPWSTR; cch: DWORD; var pdwPriority: DWORD;
      var prgSize: TSize; dwRecClrDepth: DWORD;
      var pdwFlags: DWORD): HRESULT; stdcall;
    function Extract(var phBmpThumbnail: HBITMAP): HRESULT; stdcall;
  end;

The links you provided don't compile, because of missing units, which I don't have.
The only one I have is GraphicEx by Mike Lischke, and that also doesn't compile

The links should only show you how to implement IExtractImage Interface and it is not necessary that you can compile them

I am aware of that, however, the bits which are being used seem to be the same, I am using.
Therefore I tried to compile the examples. to see, where they differ from my implementation.

I think I need a working example.

I don't know, how the point system works, but I am willing to give a lot of points for a solution.

According this and this suggestion - try to use ShellItemImage interface...

const
  SIIGBF_RESIZETOFIT   = $00000000;
  SIIGBF_BIGGERSIZEOK  = $00000001;
  SIIGBF_MEMORYONLY    = $00000002;
  SIIGBF_ICONONLY      = $00000004;
  SIIGBF_THUMBNAILONLY = $00000008;
  SIIGBF_INCACHEONLY   = $00000010;

type
  SIIGBF = Integer;

  IShellItemImageFactory = interface(IUnknown)
    ['{BCC18B79-BA16-442F-80C4-8A59C30C463B}']
    function GetImage(size: TSize; flags: SIIGBF; out phbm: HBITMAP): HRESULT; stdcall;
  end;

function GetThumbnailPtr(const aFileName: UTF8String; aSize: TSize; out Bitmap: HBITMAP): HRESULT;
var
  ShellItemImage: IShellItemImageFactory;
begin
  Result:= SHCreateItemFromParsingName(PWideChar(UTF8Decode(aFileName)), nil,
                                       IShellItemImageFactory, ShellItemImage);
  if Succeeded(Result) then
  begin
    Result:= ShellItemImage.GetImage(aSize, SIIGBF_THUMBNAILONLY, Bitmap);
  end;
end;

function GetThumbnail(const aFileName: UTF8String; aSize: TSize): TBitmap;
var
  hBmp: HBITMAP;
  Status: HRESULT;
begin
  Result:= nil;

  Status := E_FAIL;
  if (Win32MajorVersion > 5) then
  begin
    Status:= GetThumbnailPtr(aFileName, aSize, hBmp);
  end;

  if Succeeded(Status) then
  begin
    Result:= TBitmap.Create;
    Result.Handle:= hBmp;
  end;
end;

procedure TForm1.Button6Click(Sender: TObject);
var
  sz: TSize;
begin
  sz.cx := 100;
  sz.cy := 100;
  Image1.Picture.Assign(GetThumbnail(Edit1.Text, sz));
end;

Select allOpen in new window

.... and some sort of viewer must be installed too - for specific file types like pdfs - Adobe or some others.
Otherwise, you will encounter - not implemented error

I stumbled across this as well (Remy Lebeau of Embarcadero)
Not sure, how to give points, but I would like to give them to you anyway, because you made the necessary effort.

What I found:

IShellItemImageFactory = interface(IUnknown)
    ['{BCC18B79-BA16-442F-80C4-8A59C30C463B}']
    function GetImage(size: TSize; flags: SIIGBF; out phbm: HBITMAP): HRESULT; stdcall;
  end;

function TForm1.GetThumb(AFilePath: string; var hBmp: HBITMAP): HRESULT;
var
  fileShellItemImage: IShellItemImageFactory;
  s: TSize;
begin
  Result := CoInitializeEx(nil, COINIT_APARTMENTTHREADED or COINIT_DISABLE_OLE1DDE);
  if Succeeded(Result) then
  begin
    Result := SHCreateItemFromParsingName(PChar(AFilePath), nil, IShellItemImageFactory, fileShellItemImage);
    if Succeeded(Result) then
    begin
      s.cx := 120;
      s.cy := 120;
      Result := fileShellItemImage.GetImage(s, SIIGBF_THUMBNAILONLY, hBmp);
    end;
    CoUninitialize;
  end;
end;

procedure TForm1.Button4Click(Sender: TObject);
var Bmp: HBitMap;
    Bmp1: TBitmap;
    FName, FName2: String;
begin
  if OpenDialog1.Execute then begin
    FName := OpenDialog1.FileName;
    Bmp1 := TBitMap.Create;
    Bmp1.Height := 120;
    Bmp1.Width := 120;
    try
      GetThumb(FName, Bmp);
    except
      on E: Exception do ShowMessage(E.Message);
    end;
    BMP1.Handle := Bmp;
    FName2 := ChangeFileExt(FName,'.bmp');
    BMP1.SaveToFile(FName2);
    Image1.Picture.LoadFromFile(FName2);
  end;
end;

This however, only started to work, after I installed Foxit PDF Reader on all of my Computers, as Adobe apparently lost the ability to extract Images for Preview

Regards
Wolfgang

Yes, this Adobe problem is described.... But try to change line:

...
Result := fileShellItemImage.GetImage(s, SIIGBF_THUMBNAILONLY, hBmp);
...

Select allOpen in new window

to:

...
Result := fileShellItemImage.GetImage(s, SIIGBF_RESIZETOFIT, hBmp);
...

Select allOpen in new window

or try another code based upon IThumbnailCache interface:

const
  CLSID_LocalThumbnailCache: TGuid = '{50EF4544-AC9F-4A8E-B21B-8A26180DB13F}';
  CLSID_SharedBitmap: TGuid = '{4db26476-6787-4046-b836-e8412a9e8a27}';

type
  {$EXTERNALSYM WTS_FLAGS}
  WTS_FLAGS = (
    WTS_EXTRACT = 0,
    WTS_INCACHEONLY = 1,
    WTS_FASTEXTRACT = 2,
    WTS_FORCEEXTRACTION = 4,
    WTS_SLOWRECLAIM = 8,
    WTS_EXTRACTDONOTCACHE = 32,
    WTS_SCALETOREQUESTEDSIZE = 64,
    WTS_SKIPFASTEXTRACT = 128,
    WTS_EXTRACTINPROC = 256
  );

  {$EXTERNALSYM WTS_CACHEFLAGS}
  WTS_CACHEFLAGS = (
    WTS_DEFAULT = 0,
    WTS_LOWQUALITY = 1,
    WTS_CACHED = 2
  );
  PWTS_CACHEFLAGS = ^WTS_CACHEFLAGS;

  {$EXTERNALSYM WTS_ALPHATYPE}
  WTS_ALPHATYPE = (
    WTSAT_UNKNOWN = 0,
    WTSAT_RGB = 1,
    WTSAT_ARGB = 2
  );

  {$EXTERNALSYM WTS_THUMBNAILID}
  WTS_THUMBNAILID = record
    rgbKey: array[0..15] of Byte;
  end;
  PWTS_THUMBNAILID = ^WTS_THUMBNAILID;

  {$EXTERNALSYM ISharedBitmap}
  ISharedBitmap = interface(IUnknown)
    ['{091162a4-bc96-411f-aae8-c5122cd03363}']
    function GetSharedBitmap(out phbm: HBITMAP): HRESULT; stdcall;
    function GetSize(out pSize: TSize): HRESULT; stdcall;
    function GetFormat(out pat: WTS_ALPHATYPE): HRESULT; stdcall;
    function InitializeBitmap(hbm: HBITMAP; wtsAT: WTS_ALPHATYPE): HRESULT; stdcall;
    function Detach(out phbm: HBITMAP): HRESULT; stdcall;
  end;

  {$EXTERNALSYM IThumbnailCache}
  IThumbnailCache = interface(IUnknown)
    ['{F676C15D-596A-4ce2-8234-33996F445DB1}']
    function GetThumbnail(pShellItem: IShellItem; cxyRequestedThumbSize: UINT;
      flags: WTS_FLAGS; out ppvThumb: ISharedBitmap; pOutFlags: PWTS_CACHEFLAGS;
      pThumbnailID: PWTS_THUMBNAILID): HRESULT; stdcall;
    function GetThumbnailByID(thumbnailID: WTS_THUMBNAILID; cxyRequestedThumbSize: UINT;
      out ppvThumb: ISharedBitmap; pOutFlags: PWTS_CACHEFLAGS): HRESULT; stdcall;
  end;

Procedure MirrorVertical(var Picture: TBitmap);
var BMP: TBitmap;
     i,j: integer;
begin
BMP := TBitmap.Create;
BMP.Assign(Picture);
for i := 0 to BMP.Height-1 do
  for j := 0 to BMP.Width-1 do
   Picture.canvas.Pixels[j, BMP.Height-i-1] := BMP.canvas.Pixels[j, i];
BMP.free;
end;

procedure ResizeBitmap(Bitmap: TBitmap; const NewWidth, NewHeight: integer);
begin
  Bitmap.Canvas.StretchDraw(
    Rect(0, 0, NewWidth, NewHeight),
    Bitmap);
  Bitmap.SetSize(NewWidth, NewHeight);
end;

function GetThumbFromCache(AFileName: string; out Bmp: TBitmap; AMaxSize: Integer = 120): HRESULT;
var
  thumbcache: IThumbnailCache;
  sharedbmp: ISharedBitmap;
  shellitem: IShellItem;
  thumbflags: PWTS_CACHEFLAGS;
  thumbid: PWTS_THUMBNAILID;
  thumbsize: TSize;
  hBmp: HBITMAP;
begin
  if not Assigned(Bmp) then
    Exit;

  Result := CoInitialize(Nil);

  Result := CoCreateInstance(
    CLSID_LocalThumbnailCache,
    nil,
    CLSCTX_INPROC,
    IThumbnailCache,
    thumbcache
  );

  if Succeeded(Result) then
  begin
    Result := SHCreateItemFromParsingName(
      PChar(AFileName),
      nil,
      IShellItem,
      shellitem
    );

    if Succeeded(Result) then
    begin
      Result := thumbcache.GetThumbnail(
        shellitem,
        AMaxSize,
        WTS_EXTRACT,
        sharedbmp,
        nil, //thumbflags,
        nil //thumbid
      );

      if Succeeded(Result) then
      begin
        sharedbmp.GetSize(thumbsize);
        Result := sharedbmp.GetSharedBitmap(hBmp);
        if Succeeded(Result) then
        begin
          bmp.SetSize(thumbsize.cx, thumbsize.cy);
          bmp.Handle := hBmp;
          bmp.Dormant;

          ResizeBitmap(bmp, AMaxSize, MulDiv(AMaxSize,thumbsize.cy, thumbsize.cx));
          //FlipBmp(bmp);
          MirrorVertical(Bmp);
        end;
      end;

      CoUninitialize;
    end;
  end;
end;

Select allOpen in new window

(modified version of original...)

So how do I give you the points?

Not sure what to do, so I have clicked on Best Solution and it made a tick there.
Is that enough? I did that before, but didn't seem to work.....

Did you follow this (new) steps... Seems that they change them a bit....

Seems to have worked now.

Regards
Wolfgang