Галерея изображений...

[Alex2013]

В общем столкнулся я с тем что моя поделка (переделанная из модуля использовавшегося для видео наблюдения)...



...начинает постепенно все меньше соответствовать подрастающему уровню моей программы .


Копнув сеть с удивлением обнаружил что найти исходники чего-то подходящего совсем непросто .
Может кто нибудь знает где можно найти исходники чего-то похожего как пример ?
(Или поделиться своей старой разработкой )
Зы
Про фокус с TListView + TImageList наслышан ... но как-то это громоздко выходит моя поделка не ахти что-то ( во основе куча TImage + TScrollBox ) и то как-то более "конкретно" смотрится. Но возможно я просто "не умею их готовить".(это про TListView + TImageList )

[Alex2013]

Типа галерея на минималках ( собрано из двух примеров найденных в сети )...

Не хотел я с TImageList связываться и был прав ...
Странностей вагон и функционал все равно допиливать нужно.

Код: Выделить всё


unit Unit1;

{$MODE Delphi}

interface

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

type

  { TForm1 }

  TForm1 = class(TForm)
    Button1: TButton;
    ComboBox1: TComboBox;
    ImageList1: TImageList;
    ListView1: TListView;
    Panel1: TPanel;
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure ComboBox1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;
  TImgLoadingThread = class(TThread)
  protected
    b1: TBitmap;
    s1: integer;
    FileName: string;
    procedure Execute; override;
    procedure Sync;
  end;

var
  Form1: TForm1;
  implementation

{$R *.lfm}

  procedure TImgLoadingThread.Execute;
const dir = 'H:\!\';
var
  sr: TSearchRec;
  img: TPicture;
  bmp: TBitmap;
  procedure CreateTumb(b: TBitmap; sz: integer);
  begin
    b.Width := sz; b.Height := sz;
    b.Canvas.StretchDraw(b.Canvas.ClipRect, bmp);
  end;
begin
  if FindFirst(dir + '*.jpg', faAnyFile, sr) = 0 then
  begin
    img := TPicture.Create;
    bmp := TBitmap.Create;
    b1 := TBitmap.Create;
    repeat
      try
        FileName := sr.Name;
        if FileName[1] = '.' then Continue;
        img.LoadFromFile(dir + FileName);
        bmp.Assign(img.Graphic);
        CreateTumb(b1, s1);
        Synchronize(Sync);
      finally
      end;
    until FindNext(sr) <> 0;
    FindClose(sr);
    b1.Free;
    bmp.Free;
img.Free;
  end;
end;

procedure TImgLoadingThread.Sync;
begin
  Form1.ImageList1.Add(b1, nil);
  with Form1.ListView1.Items.Add do
  begin
    Caption := FileName;
    ImageIndex := Form1.ListView1.Items.Count-1;
  end;
end;

procedure TForm1.FormCreate(Sender: TObject);
var
  I : Integer;
  ListItem : TListItem;
  NewColumn : TListColumn;
begin
  // Создание элементов ListView для каждого изображения в ImageList
  with ListView1 do
  begin
    SmallImages := ImageList1;
    LargeImages := ImageList1;
    //Создание двух колонок отображения в режиме vsReport
    NewColumn := Columns.Add;
    NewColumn.Caption := 'Колонка 1';
    NewColumn := Columns.Add;
    NewColumn.Caption := 'Колонка 2';
    //Добавление стилей View и констант в ComboBox
    ComboBox1.Items.AddObject('vsIcon', TObject (vsIcon));
    ComboBox1.Items.AddObject('vsList', TObject (vsList));
    ComboBox1.Items.AddObject('vsReport', TObject (vsReport));
    ComboBox1.Items.AddObject('vsSmallIcon', TObject (vsSmallIcon));
    //Отображение первого элемента ComboBox
    ComboBox1.ItemIndex := 0;
end;

end;
procedure TForm1.Button1Click(Sender: TObject);
begin
  Self.ListView1.Clear;
  Self.ImageList1.Clear;

ImageList1.Width:=200;
ImageList1.Height:=200;

with TImgLoadingThread.Create(true) do
    begin
      FreeOnTerminate := True;
      s1 := ImageList1.Width;
      Resume;
    end;
ImageList1.Width:=100;
ImageList1.Height:=150;
end;

procedure TForm1.ComboBox1Click(Sender: TObject);
begin
  with ComboBox1 do
    ListView1.ViewStyle := TViewStyle (Items.Objects [ItemIndex]);
end;

end.


Зы
Пример непоняток :
Интересно если ставлю ImageList1.Width:=100; ImageList1.Height:=150; до начала загрузки получаю "белый квадрат малевича" если после все пучком .
Непонятно, а все непонятное ненадежно ... Кто-то стакивался ?
Еще нет подгонки содержимого ListView под размер окна при изменения его размера . Это где-то включается ?

[Alex2013]

Еще нет подгонки содержимого ListView под размер окна...

Нашел решение :
IconOptions.AutoArrange = True и ScrollBars = ssAutoVertical

Но вылезла новая "проблема" Выделение элемента совсем не то что нужно для галереи ...
Старое "прибил" так :

Код: Выделить всё

procedure TForm1.ListView1SelectItem(Sender: TObject; Item: TListItem;
  Selected: Boolean);
begin
Item.Selected:=False;
end;


Но нужна "рамка вокруг миниатюры".

Добавлено спустя 1 час 15 минут 56 секунд:

Код: Выделить всё

const
LVM_SETEXTENDEDLISTVIEWSTYLE = $1036;
LVS_EX_BORDERSELECT = $8000;
...
SendMessage(ListView.Handle, LVM_SETEXTENDEDLISTVIEWSTYLE, 0, LVS_EX_BORDERSELECT)


Хм ! Как-то это странно (Вроде расхожая фишка а приходится через WinAPI лезть ) ... но работает .

Добавлено спустя 17 часов 39 минут 54 секунды:
Всю ночь провозился пытаясь сменить цвета выделения выбранного элемента....
Брр... И ведь в дельфи работает! ( например так .)
SysListView32.zip
А в лазарусе хоть тресни нет .

Добавлено спустя 2 часа 7 минут 41 секунду:
"Муки творчества" блин !

Код: Выделить всё

  procedure TForm1.ListView1AdvancedCustomDrawItem(Sender: TCustomListView;
  Item: TListItem; State: TCustomDrawState; Stage: TCustomDrawStage;
  var DefaultDraw: Boolean);
  Var  A_Rect: TRect;
begin
case (Stage) of
  cdPrePaint  : begin
    if cdsSelected in State then
    with Sender.Canvas do begin
     Item.Selected := False;
     font.Color:= clWhite;
     Brush.Color := clRed;
     Pen.Color:=ClGreen;
    end;
  end;
  cdPostPaint : begin
    if cdsSelected in State then
    with Sender.Canvas do begin
      Item.Selected := True;
     A_Rect:=Item.DisplayRect(drSelectBounds);
        Pen.Color:=ClRed;
        Pen.Width:=2;
        Brush.Color :=ClGreen;

     Frame(A_Rect.Left+1,A_Rect.Top+1,
          A_Rect.Right-1,A_Rect.Bottom);

     Brush.Color := clWindow;
     Pen.Color:=  clWindow;
    end;
  end;
end;
end;


Зы
Совсем чисто "без рисования" не обошлось ( рамку рисую сам ), но в принципе это самый простой и по идее надежный вариант из всех опробованных.

[Alex2013]

Для лучшего тестирования галереи сделал простой просмотрщик изображений ...

TListView04.7z