Extraccion de Miniatura de Archivo .ODT (Open/LibreOffice)
 

Hola gente del Foro!

Hace un tiempo buscando por la red encontré un código que me devuelve una miniatura de un archivo o su ícono.
Utiliza IExtract para hacer esto.
Funciona correctamente con imágenes, archivos Word, Excel, PDF, etc.
Cuando quiero obtener la miniatura de un archivo .odt (Open/LibreOffice) se cuelga el programa.

Os dejo a continuación adjunto los fuentes de un pequeño programa ejemplo.

ShObjIdlQuot.pas es una unidad con la definición de cosas auxiliares.
ShellObjHelper.pas es la unidad que hace el trabajo.
UFMMain.pas/dfm es el programa ejemplo que utiliza estas unidades.

Por lo que vi y hasta donde puedo llegar con mis conocimientos:
Se llama a GetExtractImageItfPtr (Archivo, XtractImage)
XtractImage es diferente de nil.
Se llama a ExtractImageGetFileThumbnail(XtractImage, MINIATURA_WIDTH, MINIATURA_HEIGHT, ColorDepth, Flags, RT, Bmp)
Dentro de este procedimiento se llama a XtractImage.GetLocation(...)
Con varios archivos devuelve NOERROR (0) o E_PENDING (-24...)
Si lo llamo con un archivo que no sea .odt XtractImage sigue siendo diferente de nil.
Si es .odt XtractImage se vuelve nil y todo empieza a fallar.

Espero que alguien con conocimientos de la API o de estas interfaces me pueda dar una solución :confused:

Gracias!

Código Delphi [-]
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;

   // ***********************************
   // Esto se comporta diferente si el archivo es .odt
   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
         OleCheck(XtractImage.Extract(BmpHandle)); // This could consume a long time.
         // If RunnableTask is available
         // then calling Kill() method
         // will immediately abort the process.
         Bmp.PixelFormat := pf32Bit;
         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;

Supongo que tienes OpenOffice instalado, si no es así no funcionará.

Asumiendo que está correctamente instalado, prueba de esta manera:

Código Delphi [-]
uses ActiveX, ShlObj, ComObj;

type
 IExtractImage = interface ['{BB2E617C-0920-11d1-9A0B-00C04FC2D6C1}']
  function GetLocation(pszPathBuffer: LPWSTR; cchMax: DWORD; var pdwPriority: DWORD; const prgSize: SIZE; dwRecClrDepth: DWORD; var pdwFlags: DWORD): HRESULT; stdcall;
  function Extract(var phBmpImage: HBITMAP): HRESULT; stdcall;
 end;

function CreateThumbnail(Path, FileName: PWCHAR; Width,  Height: Cardinal; var pBitmap: HBITMAP): HRESULT;
var
   pIExtractImage: IExtractImage ;
   Desktop, Folder: IShellFolder;
   pidList: PITEMIDLIST;
   Flags: Cardinal;
   Size: TSize;
   szBuffer: array [0..MAX_PATH] of WCHAR;
begin
   Flags:= $004; //IEIFLAG_ASPECT;
   Size.cx:= Width; Size.cy:= Height;
   Result:= E_ABORT;
   if SUCCEEDED(SHGetDesktopFolder(Desktop)) then
   begin
      if SUCCEEDED(Desktop.ParseDisplayName(0, nil, Path, PDWORD(0)^, pidList, PDWORD(0)^)) then
      begin
         if SUCCEEDED(Desktop.BindToObject(pidList, nil, IShellFolder, Folder)) then
         begin
            CoTaskMemFree(pidList);
            if SUCCEEDED(Folder.ParseDisplayName(0, nil, FileName, PDWORD(0)^, pidList, PDWORD(0)^))then
            begin
               Result:= Folder.GetUIObjectOf(0, 1, pidList, IExtractImage, nil, pIExtractImage);
               CoTaskMemFree(pidList);
               if SUCCEEDED(Result) then
               begin
                  Result:= pIExtractImage.GetLocation(szBuffer, MAX_PATH, PDWORD(0)^, size, 24, Flags);
                  if SUCCEEDED(Result) or (Result = E_PENDING) then
                     Result:= pIExtractImage.Extract(pBitmap);
               end;
            end;
         end;
      end;
   end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  Bitmap: HBITMAP;
begin
  CreateThumbnail('C:\', 'Ejemplo.odt', 96, 96, Bitmap);
  Image1.Picture.Bitmap.Handle:= Bitmap;
end;

Saludos.

¡¡¡MUCHÍSIMAS GRACIAS ESCAFANDRA!!!
Te voy a poner al nivel de Neftali y sus 11K mensajes

Hacía ya varios días que le estaba dando vuelvas a esto y no encontraba solución.
No entiendo porqué tu función da resultado y la que implemento yo no. Ambas utilizan IExtractImage.GetLocation e IExtractImage.Extract.
Algún día trataré de estudiar un poco la lógica detrás de estas Interfaces.

Repito: MUCHAS GRACIAS! y felices inmersiones...