IExtractImage Delphi

Extracting a Preview into a BitMap File is no longer working
FolderISF.GetUIObjectOf(0, 1, pItemIDL, IExtractImage, nil, IExtractImg);

IExtractImg is always Nil.

Win10
DelphiXE7
WRiederOwnerAsked:
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

ThommyCommented:
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
WRiederOwnerAuthor Commented:
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
ThommyCommented:
-2147467263 (decimal) = 0x80004001(hex)
Common HRESULT valuesSeems 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...
C++ 11 Fundamentals

This course will introduce you to C++ 11 and teach you about syntax fundamentals.

WRiederOwnerAuthor Commented:
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
ThommyCommented:
The links should only show you how to implement IExtractImage Interface and it is not necessary that you can compile them
WRiederOwnerAuthor Commented:
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.
Sinisa VukSoftware architectCommented:
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;

Open 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
WRiederOwnerAuthor Commented:
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
Sinisa VukSoftware architectCommented:
Yes, this Adobe problem is described.... But try to change line:
...
Result := fileShellItemImage.GetImage(s, SIIGBF_THUMBNAILONLY, hBmp);
...

Open in new window

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

Open 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;

Open in new window

(modified version of original...)
WRiederOwnerAuthor Commented:
So how do I give you the points?
Sinisa VukSoftware architectCommented:
Follow this EE question ...

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
WRiederOwnerAuthor Commented:
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.....
Sinisa VukSoftware architectCommented:
Did you follow this (new) steps... Seems that they change them a bit....
WRiederOwnerAuthor Commented:
Seems to have worked now.

Regards
Wolfgang
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Delphi

From novice to tech pro — start learning today.