¿Saben de algún componente que realice ésta función?

[manuc]

Ok, pues te dejo esta función que hace justo lo que quieres.

Con esta función puedes generar el thumbnail, a apartir de la ruta hasta el fichero. Hay varias formas de hacer esto, pero esta es la que mejor me ha funcionado.

Código Delphi [-]
function GetThumbnail(lpPathName, lpFileName: PWideChar; Width, Height: Integer): TBitmap;
var
 Desktop, Folder: IShellFolder;
 ItemIDList: PItemIDList;
 Flags, Priority: Cardinal;
 ExtractImage: IExtractImage;
 Res: HRESULT;
 hBitmap: Windows.HBITMAP;
 Buffer: array[0..MAX_PATH-1] of WideChar;
 Size: TSize;
begin
  Result := nil;
  SHGetDesktopFolder(Desktop);
  if LongBool(Desktop.ParseDisplayName(0, nil, lpPathName, PDWORD(0)^, ItemIDList, PDWORD(0)^)) then Exit;
  Desktop.BindToObject(ItemIDList, nil, IShellFolder, Folder);
  CoTaskMemFree(ItemIDList);
  if LongBool(Folder.ParseDisplayName(0, nil, lpFileName, PDWORD(0)^, ItemIDList, PDWORD(0)^)) then Exit;
  Folder.GetUIObjectOf(0, 1, ItemIDList, IExtractImage, nil, ExtractImage);
  CoTaskMemFree(ItemIDList);
  if not Assigned(ExtractImage) then Exit; // TODO
  Size.cx := Width; Size.cy := Height; Priority := 0;
  Flags := $28{IEIFLAG_SCREEN+IEIFLAG_OFFLINE};
  Res := ExtractImage.GetLocation(Buffer, SizeOf(Buffer), Priority, Size, 24{pf32bit}, Flags);
  if (Res = NOERROR) or (Res = E_PENDING{IEIFLAG_ASYNC}) then
  begin
    if not LongBool(ExtractImage.Extract(hBitmap)) then
    begin
     Result := TBitmap.Create;
     Result.Handle := hBitmap;
    end;
  end;
end;

¿cómo utilizarla? Por ejemplo:

Código Delphi [-]
Var
  bmp:TBitmap;
  vFichero:WideString;
  vRuta:WideString;
begin
  vRuta    := ExtractFilePath(path_fichero_pdf);
  vFichero := ExtractFilename(path_fichero_pdf);

  bmp := GetThumbnail(PWideChar(vRuta), PWideChar(vFichero), 122, 200);
  Image1.Picture.Assign(bmp);
  freeandnil(bmp)

Espero que te ayude.
Cualquier cosa, consulta sin problemas.

Un saludo.

[TiammatMX]

Empezado por manuc

...Espero que te ayude.
Cualquier cosa, consulta sin problemas...

Gracias manuc, está excelente tu función, y de hecho sí tengo una consulta.

Pretendo que el PDF que voy a mostrar resida en un campo binary de MS SQL server y se muestre en un TPanel justo con una funcionalidad parecida a la que amablemente me proporcionaste. ¿Qué adecuaciones debería hacerle? O tal vez, grabar momentáneamente el archivo en disco para ser mostrado.

Muy agradecido por tu excelente respuesta.

[manuc]

Hola tiammat,

Me alegro que te ayude.

Si te refieres a modificar la función para que genere el thumbnail directamente del campo en base de datos ... creo que no sería posible o yo no sabría hacerlo.

Si existe un proceso en tu Software para enviar el fichero a base de datos, yo aprovecharía este proceso para generar el thumbnail y guardarlo en un campo en base de datos.

Depende un poco del tamaño de los ficheros PDF. Si cada vez que quieres generar el thumbnail "extraes" el fichero de base de datos, puede ser que generes un tráfico no necesario, dado que es probable que muchos casos el usuario no llegue a utilizar el PDF.

Pero esto ya depende del criterio de cada uno.

Un saludo!

[TiammatMX]

Empezado por manuc

Hola tiammat,

Me alegro que te ayude...

Una pregunta, manuc, ¿me hace falta algo, alguna unit o función para utilizar el código éste? Por que me marca errores:

[Error][Error] ufrmContenedor.pas(808): Undeclared identifier: 'IExtractImage'
[Error] ufrmContenedor.pas(820): Undeclared identifier: 'CoTaskMemFree'
[Error] ufrmContenedor.pas(828): Incompatible types
[Error] ufrmContenedor.pas(833): Missing operator or semicolon
[Error] ufrmContenedor.pas(837): ')' expected but identifier 'Extract' found
[Error] ufrmContenedor.pas(857): Incompatible types: 'WideString' and 'PWideChar'
[Error] ufrmContenedor.pas(857): Incompatible types: 'WideString' and 'PWideChar'
[Fatal Error] TSDocumentos.dpr(6): Could not compile used unit 'ufrmContenedor.pas'

y como lo tengo implementado es así...

Código Delphi [-]
procedure TfrmContenedor.VisualizaMiniatura(sIDDocumento,sConsPac: string);

  procedure BajaPDF(sNombreArchivo : string);
  var
    qryTemporal : TADOQuery;
    msFlujo : TMemoryStream;
  begin
    qryTemporal := TADOQuery.Create(Self);
    with qryTemporal do
    begin
      Connection := qryDocumentos.Connection;
      SQL.Clear;
      SQL.Add('Select HY11_DocumentoElectronico from HY11_DocumentosPacElec where (E2_CTRL_PAC = '+lblExpediente.Caption+') AND ('+chklstDocumentos.Items.Strings[chklstDocumentos.ItemIndex])+');');
      Open;
      if RecordCount > 0 then
      begin
        msFlujo := TMemoryStream.Create;
        try
          TBlobField(qryTemporal.FieldByName('HY11_DocumentoElectronico')).SaveToStream(msFlujo);
          msFlujo.Position := 0;
          msFlujo.SaveToFile(sNombreArchivo);
        finally
          msFlujo.Free;
          msFlujo.Destroy;
        end;
      end;
      Close;
      Destroy;
    end;
  end;

  function CreaThumbnail(sRuta, sArchivo : PWideChar; Width, Height: Integer) : TBitmap;
  var
    Desktop, Folder: IShellFolder;
    ItemIDList: PItemIDList;
    Flags, Priority: Cardinal;
    ExtractImage: IExtractImage;
    Res: HRESULT;
    hBitmap: Windows.HBITMAP;
    Buffer: array[0..MAX_PATH-1] of WideChar;
    Size: TSize;
  begin
    Result := nil;
    SHGetDesktopFolder(Desktop);
    if LongBool(Desktop.ParseDisplayName(0, nil, sRuta, PDWORD(0)^, ItemIDList, PDWORD(0)^)) then
      Exit;

    Desktop.BindToObject(ItemIDList, nil, IShellFolder, Folder);
    CoTaskMemFree(ItemIDList);

    if LongBool(Folder.ParseDisplayName(0, nil, sArchivo, PDWORD(0)^, ItemIDList, PDWORD(0)^)) then
      Exit;

    Folder.GetUIObjectOf(0, 1, ItemIDList, IExtractImage, nil, ExtractImage);
    CoTaskMemFree(ItemIDList);

    if not Assigned(ExtractImage) then
      Exit;

    Size.cx := Width; Size.cy := Height; Priority := 0;
    Flags := $28{IEIFLAG_SCREEN+IEIFLAG_OFFLINE};
    Res := ExtractImage.GetLocation(Buffer, SizeOf(Buffer), Priority, Size, 24{pf32bit}, Flags);
    
    if (Res = NOERROR) or (Res = E_PENDING{IEIFLAG_ASYNC}) then
    begin
      if not LongBool(ExtractImage.Extract(hBitmap)) then
      begin
       Result := TBitmap.Create;
       Result.Handle := hBitmap;
      end;
    end;

  end;

var
  sFolder, sNombreArchivo : widestring;
  bmImagen : TBitmap;
begin
  sFolder := ObtenerFolder+'\';
  sNombreArchivo := 'TMP'+Trim(lblExpediente.Caption)+Trim(Texto2ID(chklstDocumentos.Items.Strings[chklstDocumentos.ItemIndex]))+'.pdf';
  ShowMessage(Format('La carpeta Mis Documentos para el usuario actual es: "%s"'+CRLF+'y el nombre de archivo temporal será: "%s"',[sFolder,sNombreArchivo]));

  if NOT FileExists(sFolder+sNombreArchivo) then
    BajaPDF(sFolder+sNombreArchivo);

  bmImagen := CreaThumbnail(sFolder,sNombreArchivo,imgMiniatura.Width,imgMiniatura.Height);
  imgMiniatura.Picture.Assign(bmImagen);
  FreeAndNil(bmImagen);
end;

¿Habrá algo que falte? Oriéntame, por favor.

[manuc]

ohh!!

Perdona, fallo mío.

Me faltaba este trozo de código :-) :

Código Delphi [-]
type
 IExtractImage = interface ['{BB2E617C-0920-11d1-9A0B-00C04FC2D6C1}'] // http://msdn2.microsoft.com/en-us/lib...48(VS.85).aspx
  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;

Te he preparado una demo, que puedes descargarla aquí: www.applinet.es/descargas/thumbnail_demo.zip

¿Puedes probarlo con añadiendo este código?
Cuéntame como te fue.

Un saludo.

Manuel.

[TiammatMX]

Empezado por manuc

ohh!! ...

¡¡¡¡AAAAAHHHHHHHHH!!!! Gracias a tu participación (The Beatles tenía mucha razón con éso de "with a little help from my friends") la aplicación ha quedado espectacular.

Solamente que en la primera corrida (el TImage "virgen", la memoria sin ningún dato) me arroja una excepción, pero quiero creer que es por que aún no tiene nada...

Muchas gracias, Manuel. No sabes cuánto de lo agradezco.

[manuc]

jaja, me alegro que vaya bien!

Nada, hoy por ti, mañana por mí

Un saludo.