Nahled jpg obrazku, miniatur, v ListView – Delphi – Fórum – Programujte.com

Zdravim,
jak jsem psal v predchazejicim vlakne, zalozil jsem tohle nove pro jednak lepsi prehled a druhak kvuli presnejsimu nazvu.

Problem ovsem zustava.

Jak psal zlz:

A zkoušel jsi číst dokumentaci?

TListView.LargeImages obsahuje obrázky. Ty v něm máš načtené systémové ikony.
TListItem.ImageIndex určuje index obrázku ^^. Ty ho nastavuješ na index systémové ikony.

Jestli chceš zobrazovat náhledy, tak si místo ikon načti ty náhledy a nastav odpovídající index. Na získání náhledů zase můžeš použít funkce shellu, konkrétně to umí třeba IExtractImage interface, nebo funkce Delphi (TBitmap?).

koukal jsem se na ty stranky a ac to vypada vsechno jednoduse, tak vlastni zapis jsem do kupy nedal.

zkousel jsem hledat i kody pro Delphi,kde by bylo obsazeno IExtractImage, ale taky marne.

Mam tedy tenhle kod: 

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, ShellAPI, Classes, Graphics, Controls, Forms,
  Dialogs, ComCtrls, ImgList, StdCtrls;

type
  TForm1 = class(TForm)
    DirEdit: TEdit;
    ShowBtn: TButton;
    LargeFileImages: TImageList;
    FileView: TListView;
    procedure ShowBtnClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;
  SFI: TSHFileInfo;

implementation

{$R *.dfm}

procedure TForm1.ShowBtnClick(Sender: TObject);
var
  Found: Integer;
  SearchRec: TSearchRec;
begin
  // odstraníme všechny položky
  FileView.Items.Clear;
  // zahájíme hledání
  Found := FindFirst(DirEdit.Text + '\*.jpg', faAnyFile - faVolumeID, SearchRec);
  // opakujeme, dokud existují vyhovující soubory
  while Found = 0 do
  begin
    if (SearchRec.Name <> '.') and (SearchRec.Name <> '..') then
      with FileView.Items.Add do // přidíme položku
      begin
        SHGetFileInfo(
          PChar(DirEdit.Text + '\' + SearchRec.Name), // cesta k souboru
          0,                                          // atributy - žádné
          SFI, SizeOf(SFI),                           // struktura TSHFileInfo
          // vlajky: chceme získat index velké ikony a jméno souboru
          SHGFI_SYSICONINDEX + SHGFI_LARGEICON + SHGFI_DISPLAYNAME
        );
        Caption := SFI.szDisplayName; // nastavíme název
        ImageIndex := SFI.iIcon;      // a index ikony
      end;
    Found := FindNext(SearchRec);
  end;
  // konec hledání
  FindClose(SearchRec);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  LargeFileImages.Handle := SHGetFileInfo(
    PChar(Application.ExeName), // jelikož nám jde o handle ImageListu,
    0,                          // můžeme použít libovolný soubor - třeba
    SFI, SizeOf(SFI),           // "exáč" aplikace
    SHGFI_SYSICONINDEX + SHGFI_LARGEICON
  );
end;
end.

a chtel bych Vas poprosit, pokud by jste mi pomohli ho predelat tak jak pise zlz pomoci IExtractImage tak aby se mi misto ikon zobrazovaly ty nahledy fotek.jpg.

Co smazat uz zhruba vim, ale nevim, co vepsat misto toho.
Nebo aspon odkaz na nejakej kod, kde se IExtractImage pouziva, me se nepodarilo nic najit.

Predem dekuji za trpelivost s mym nymandstvim ...

Původně jsem tě chtěl navigovat stejným směrem (spletl jsem názvy rozhraní :)), ale tohle není cesta pro tebe. Pro tebe je jednodušší, když půjdeš cestou Delphi fičurek.

Náhledy potřebuješ někam uložit, a to něco je TImageList. Do něj se ukládají TBitmap, ale tou JPG nenačteš. Podle všeho je tu třída TJPEGImage, která umí načítat JPG. No a když to budeš mít načtené, tak se z toho dá udělat bitmapa, kterou pak jenom zmenšíš na rozměr, který si zvolíš (rozměr, který bude uchovávat TImageList). A když si to takhle hezky uložíš, tak budeš znát index obrázku v TImageList, který nastavíš té položce v ListView (ImageIndex).

 Načtení JPG do TBitmap:

bmp: TBitmap;
jpg: TJPEGImage; 

...

jpg := TJpegImage.Create;
jpg.LoadFromFile('cesta k jpg souboru'); 

bmp := TBitmap.Create;
bmp.Assign(jpg);

// a mame z JPG bitmapu :)

A tady kupříkladu funkce na změnu velikosti bitmapy.

No a pak jenom u instance třídy TImageList zavoláš Add a jako parametr mu předáš tu zmenšenou bitmapu. On ti vrátí index, který má ta bitmapa v image listu. Ten image list bude přiřazený do ListView a té konkrétní položce přidáš tento konkrétní index :)

Jestli to budeš chtít mít o něco lepší, tak si to asi budeš muset štosovat lépe, aby sis pamatoval, které obrázky už si načítal a které ne (když se vrátíš do adresáře apod.), aby si je nemusel načítat pořád znovu a znovu. Ale na to je času dost :).

#2 liborb
to je super, ...

zkusil jsem napsat toto: (je to jen zatim slepena vec z nekolika ruznych veci a jsou tam i komponenty,treba jako label1 a pod jen kvuli kontrole. Az to bude fungovat, tak to prepisu,nebo orezu na nutny veci)

{$R *.dfm}

function ResizeBmp(bmp: TBitmap; wid, hei: Integer): Boolean;
var 
  TmpBmp: TBitmap;
  ARect: TRect;
begin
  Result := False;
  try
    TmpBmp := TBitmap.Create;
    try
      TmpBmp.Width  := wid;
      TmpBmp.Height := hei;
      ARect := Rect(0,0, wid, hei);
      TmpBmp.Canvas.StretchDraw(ARect, bmp);
      bmp.Assign(TmpBmp);
    finally
      TmpBmp.Free;
    end;
    Result := True;
  except
    Result := False;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
const
  sPath = 'd:\Delphi\Obrazky\';
var
  bmp: TBitmap;
  jpg: TJPEGImage;
  i: integer;
  SearchRec: TSearchRec;
  ListItem:  TListItem;
  FileInfo:  SHFILEINFO;
begin
  ListView1.SmallImages := ImageList1;
  ListView1.ViewStyle  := vsReport;
  ListView1.Columns.add.Width:= 150;
  Icon := TIcon.Create;
  try
    ListView1.items.BeginUpdate;
    i := FindFirst(sPath + '*.jpg', faAnyFile, SearchRec);
    while i = 0 do
      begin
        application.ProcessMessages;
        with ListView1 do
        begin
        if ((SearchRec.Attr and FaDirectory <> FaDirectory) and (SearchRec.Attr and FaVolumeId <> FaVolumeID)) then
        begin
          ListItem := ListView1.items.add;
          SHGetFileInfo(PChar(sPath + SearchRec.Name), 0, FileInfo, SizeOf(FileInfo), SHGFI_DISPLAYNAME);

          Listitem.Caption := FileInfo.szDisplayName;
          Label1.Caption:= sPath + FileInfo.szDisplayName;

          jpg := TJpegImage.Create;
          jpg.LoadFromFile(sPath + FileInfo.szDisplayName);
          bmp := TBitmap.Create;
          bmp.Assign(jpg);
          ResizeBmp(bmp,97,73);
        end;
      end;
      i := FindNext(SearchRec);
    end;
  finally
    ListView1.items.EndUpdate;
  end;
end;

end.

ale mam problem s tim, ze u prevodu z jpg na bmp  skoncim s promennou bmp, jenze nevim, jak ji dal pouzit.
treba...   Image1.Picture.LoadFromFile(bmp) nefunguje coz je jasny, ale jak to teda napsat ??
no ale hlavne to co potrebuji je, ze pri prekladu mi to hodi chybu pri volani funkce ResizeBmp( bmp,97,73) tady to bmp je taky spatne pouzity ..
poradis mi s tim jeste prosim ...
jinak potom uz priradim zresizovany fotky do  ImageList2 a nejak se prokousu tim, abych je zobrazil v ListView2.
ale prvne musim vyresit tohle, jinak me to dal nepusti ..

Ty už ji máš v paměti, takže by mělo stačit nebo jako Image1.Picture.Assign(bmp).

No a jakou chybu ti hlásí ta změna velikosti bitmapy?

Zasláno z mobilního telefonu.

#4 liborb
tady je vypis vsech zprav pri prelozeni ..

zastavi se to na radku ResizeBmp(bmp, .....   a kurzor je prave za bmp.

Build
  [Hint] Unit1.pas(38): Value assigned to 'ResizeBmp' never used
  [Warning] Unit1.pas(79): Symbol 'faVolumeID' is specific to a platform
  [Warning] Unit1.pas(79): Symbol 'faVolumeID' is specific to a platform
  [Error] Unit1.pas(93): Too many actual parameters
  [Error] Unit1.pas(93): Too many actual parameters
  [Error] Unit1.pas(19): Unsatisfied forward or external declaration: 'TForm1.ResizeBmp'
  [Fatal Error] Project2.dpr(5): Could not compile used unit 'Unit1.pas'

tech chyb je tam vic, ale jak rikam, az to zfunkcnim, budu to jeste orezavat a upravovat ....

mel jsem spatne zapsanou tu funkci, opravil jsem to, pouzil to tvoje prirazeni a uz to funguje ...
omlouvam se, ze jsem mystifikoval, byla to moje hloupost ..
tak ted jdu na to vykresleni miniatury do ListView2

tak jsem to nejak sesmolil, ale je to hrozne pomaly ..
tady je code:

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, Jpeg, StdCtrls, ShellApi, ImgList, ComCtrls, ExtCtrls;

type
  TForm1 = class(TForm)
    ListView1: TListView;
    Label1: TLabel;
    ImageList1: TImageList;
    ImageList2: TImageList;
    Button1: TButton;
    ListView2: TListView;
    Image1: TImage;
    Image2: TImage;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

function ResizeBmp(bmp1: TBitmap; wid, hei: Integer): Boolean;
var 
  TmpBmp: TBitmap;
  ARect: TRect;
begin
  Result := False;
  try
    TmpBmp := TBitmap.Create;
    try
      TmpBmp.Width  := wid;
      TmpBmp.Height := hei;
      ARect := Rect(0,0, wid, hei);
      TmpBmp.Canvas.StretchDraw(ARect, bmp1);
      bmp1.Assign(TmpBmp);
    finally
      TmpBmp.Free;
    end;
    Result := True;
  except
    Result := False;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
const
  sPath = 'd:\Delphi\Obrazky\';
var
  bmp: TBitmap;
  jpg: TJPEGImage;
  i: integer;
  SearchRec: TSearchRec;
  ListItem,ListItem2:  TListItem;
  FileInfo:  SHFILEINFO;
begin
//  ListView1.SmallImages := ImageList1;
//  ListView1.ViewStyle  := vsReport;
//  ListView1.Columns.add.Width:= 150;
  ListView2.Columns.Add;
  Icon := TIcon.Create;
  try
//    ListView1.items.BeginUpdate;
    ListView2.Items.BeginUpdate;
    i := FindFirst(sPath + '*.jpg', faAnyFile, SearchRec);
    while i = 0 do
      begin
        application.ProcessMessages;
//        with ListView1 do
          with ListView2 do
        begin
        if ((SearchRec.Attr and FaDirectory <> FaDirectory) and (SearchRec.Attr and FaVolumeId <> FaVolumeID)) then
        begin
//          ListItem := ListView1.items.add;
          ListItem2:= ListView2.Items.Add;
          SHGetFileInfo(PChar(sPath + SearchRec.Name), 0, FileInfo, SizeOf(FileInfo), SHGFI_DISPLAYNAME);
          ListItem2.Caption:= FileInfo.szDisplayName;
//          Listitem.Caption := FileInfo.szDisplayName;
          Label1.Caption:= sPath + FileInfo.szDisplayName;

          jpg := TJpegImage.Create;
          jpg.LoadFromFile(sPath + FileInfo.szDisplayName);
          bmp := TBitmap.Create;
          bmp.Assign(jpg);
          Image1.Picture.Assign(bmp);
          ResizeBmp(bmp , 97 , 73);
          Image2.Picture.Assign(bmp);
          ImageList1.Insert(i,bmp,nil);
          ListItem2.ImageIndex:= ImageList1.AddImage(ImageList1,i);

      end;
      end;
      i := FindNext(SearchRec);
    end;
  finally
    ListView2.Items.EndUpdate;
//    ListView1.items.EndUpdate;
  end;
end;

end.

tady je vysledek

Na mobilu nevidím, jestli tam je nějaká "brzda", ale jinak cos čekal? :)

Nebo jinak, jak se ta pomalost projevuje? Kolik máš souborů jpg? Jak jsou velké?

A samozřejmě to načítání musíš udělat na pozadí ve vlákně a ještě si musíš udělat vlastní seznam (jméno souboru - index v ImageList), kde si budeš kontrolovat, jestli už daný obrázek náhodou nemáš v paměti, aby si je nenačítal stále dokola, když se do nějaké adresáře opakovaně vrátíš.

Zasláno z mobilního telefonu.

necekal jsem zazraky, ... :o))   ale tohle je hodne pomaly ..
urcite ted prectu neco o vlaknech,snad zjistim o co jde,trochu tusim, a uvidim ...

rozhodne to nejaky zrychleni chce ...

a samozrejme dikec.

jsem zapomel, ..  pomalost je prave u procesu resize, ...

Chci ten program pouzit na prohlizeni fotek a tech mam moc.

V kazdym adresari je jich treba 30 a jsou velky zhruba 3 - 5 Mb

Ten resize neni pomalej, ten je prostě výpočetně náročnej. Jak tu bylo zmíněno, jediný kloudný řešení jsou vlákna, tak s chutí do nich 

Stejně tě ty vlákna neminou a jen tak mimochodem pokud to udeláš chytře, tak to bude na vícejádrovém procesoru i mnohem rychlejší. Ale teď můžeš zkusit změnit nastavení toho resize. Jsou minimálně 2 režimy: v jednom se barva každého pixelu počítá z dané oblasti a druhý - mnohem rychlejší - tam se prostě berou jen vybrané a zbytek se zahodí. Ale jak to pomůže s takovým billboardem, to netuším :)

Zasláno z mobilního telefonu.