La verdad es que no entiendo como pasarlo a modo virtual, ya que quiciera probarlo puesto a que quiero trabajaron con centenares de imagenes.
Con un Form, un Button, un ImageList, un ListView y un Image, les dejo mi codigo para visualizar como thumbnails las imagenes jpg contenidas en una carpeta.
Alguien me ayuda a como pasarlo a modo virtual??? quizas asi me de cuenta.
Les agradezco de antemano. Me baje los ejemplos, y aun asi no he conseguido pararlo a virtual, me resulto interesante el comentario de "KeyBoy"
Aqui les va mi codigo, a ver si me ayudan a modificarlo:
Código Delphi
[-]
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ComCtrls, ExtCtrls, ImgList;
type
TForm1 = class(TForm)
ListView1: TListView;
Button1: TButton;
Image1: TImage;
ImageList1: TImageList;
procedure Button1Click(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
private
public
end;
var
Form1: TForm1;
lista: TStrings;
implementation
{$R *.dfm}
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 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; Size.cx := Width; Size.cy := Height; Priority := 0;
Flags := $28;
Res := ExtractImage.GetLocation(Buffer, SizeOf(Buffer), Priority, Size, 24, Flags);
if (Res = NOERROR) or (Res = E_PENDING) then
begin
if not LongBool(ExtractImage.Extract(hBitmap)) then
begin
Result := TBitmap.Create;
Result.Handle := hBitmap;
end;
end;
end;
procedure BuscarArchivos(const directorio, mascara: string;
atributos: Integer; var listado: TStrings);
procedure Buscar(const subdirectorio: string);
var
regBusqueda: TSearchRec;
begin
if FindFirst(subdirectorio + mascara,atributos,regBusqueda) = 0 then
begin
try
repeat
Application.ProcessMessages;
if (regBusqueda.Attr and faDirectory = 0)
or (regBusqueda.Name <> '.')
and (regBusqueda.Name <> '..') then
listado.Add(subdirectorio + regBusqueda.Name);
until FindNext(regBusqueda) <> 0;
except
FindClose(regBusqueda);
end;
FindClose(regBusqueda);
end;
if FindFirst(subdirectorio + '*', atributos
or faDirectory, regBusqueda) = 0 then
begin
try
repeat
Application.ProcessMessages;
if ((regBusqueda.Attr and faDirectory) <> 0)
and (regBusqueda.Name <> '.')
and (regBusqueda.Name <> '..') then
Buscar(subdirectorio + regBusqueda.Name + '\');
until FindNext(regBusqueda) <> 0;
except
FindClose(regBusqueda);
end;
FindClose(regBusqueda);
end;
end;
begin
Buscar(IncludeTrailingPathDelimiter(directorio));
end;
procedure TForm1.Button1Click(Sender: TObject);
var AItem: TListItem;
i,w:integer;
directorio,archivo:array[0..255] of WideChar;
a,d:string;
ar,di:PWideChar;
begin
ListView1.Clear;
ImageList1.Clear;
lista := TStringList.Create;
lista.Clear;
BuscarArchivos('C:\Documents and Settings\Admin\Mis documentos\Mis imágenes', '*.jpg', faAnyFile, lista);
for w:=0 to Lista.Count-1 do
begin
a:=ExtractFileName(Lista.Strings[w]);
ar:=StringToWideChar((a),archivo,255);
d:=ExtractFilePath(Lista.Strings[w]);
di:=StringToWideChar(d,directorio,255);
try
Image1.Picture.Assign(GetThumbnail(di,ar, 96, 96));
ImageList1.Add(Image1.Picture.Bitmap,nil);
except
on E: Exception do
begin
ShowMessage('Error: '+E.Message);
EXIT;
end;
end;
end;
ListView1.Items.BeginUpdate;
for i:=0 to Lista.Count-1 do
begin
AItem := ListView1.Items.Add;
AItem.Caption := ExtractFileName(Lista.Strings[i]);
AItem.SubItems.Add(Lista.Strings[i]);
AItem.ImageIndex:=i;
end;
ListView1.Items.EndUpdate;
end;
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
Lista.Free;
end;
end.
Muchas Gracias y Saludos