IExtractImage Delphi

WRieder
WRieder used Ask the Experts™
on
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
Comment
Watch Question

Do more with

Expert Office
EXPERT OFFICE® is a registered trademark of EXPERTS EXCHANGE®

Commented:
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
WRiederOwner

Author

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

Commented:
-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...
JavaScript Best Practices

Save hours in development time and avoid common mistakes by learning the best practices to use for JavaScript.

WRiederOwner

Author

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

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

Author

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 architect
Top Expert 2012

Commented:
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
WRiederOwner

Author

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 architect
Top Expert 2012

Commented:
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...)
WRiederOwner

Author

Commented:
So how do I give you the points?
Software architect
Top Expert 2012
Commented:
Follow this EE question ...
WRiederOwner

Author

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 architect
Top Expert 2012

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

Author

Commented:
Seems to have worked now.

Regards
Wolfgang

Do more with

Expert Office
Submit tech questions to Ask the Experts™ at any time to receive solutions, advice, and new ideas from leading industry professionals.

Start 7-Day Free Trial