Szukam niestandardowej siatki obrazu

Dla Zabawy, napisałem komponent ImageGrid dla Ciebie.

Posiada tylko pionowy pasek przewijania; zmiana rozmiaru kontrolki dostosowuje liczbę kolumn i wierszy. Obrazy są buforowane w postaci zmienionych bitmap na wewnętrznej liście wraz z ich nazwami plików.

Ponieważ ładowanie i ponowne próbkowanie tych obrazów może zająć trochę czasu, w zależności od liczby obrazów, rozdzielczości i tego, czy chcesz użyć biblioteki Graphics32 dla lepszej jakości próbkowania, komponent deleguje proces ładowania do osobnego wątku, który (ponownie)uruchamia się przy ustawianiu szerokości kolumny lub wysokości wiersza oraz przy zmianie nazw plików lub ścieżki folderu, w którym komponent próbuje znaleźć wszystkie obrazy typów, które mają być dostarczone we właściwości FileFormats.

Cechy:

• tworzy i zmienia rozmiar kciuków w wątku tła, z nazw plików z biblioteką GDI+ lub z ręcznie dodawanych obrazów z biblioteką Graphics 32
• automatycznie rozpoznaje wszystkie zarejestrowane formaty plików graficznych
• animowane przewijanie
• obsługa ekranu dotykowego do przewijania przez przeciąganie siatki
• Obsługa klawiatury do wybierania kciuków
Obsługa OwnerDraw, np. do dodawania napisów do kciuków
• wirtualne wsparcie dla ominięcia automatycznego tworzenia kciuków

Właściwości i zdarzenia:

• ColCount: Liczba kolumn, readonly
• Count: Liczba zdjęć, readonly
• Images: Lista wszystkich ręcznie dodawanych obrazów, z których wewnętrznie tworzone są kciuki
• Items: Lista wszystkich kombinacji nazwa pliku-miniaturka lub obraz-miniaturka
• RowCount: liczba wierszy, readonly
• Thumbs: Lista wszystkich stworzonych wewnętrznie kciuków
• AutoHideScrollBar: ukrywa pasek przewijania, gdy wszystkie wiersze są widoczne
• BorderStyle: pokazuje lub ukrywa ramkę tematyczną
• BorderWidth: margines elementu, poza zwojem bar
• CellAlignment: align = "left", "center" lub "right" komórki
• CellHeight: Wysokość komórki
• CellLayout: wyrównuje kciuki na górze, środku lub na dole komórki
• CellSpacing: odstęp między komórkami
• CellWidth: szerokość komórki
• Color: kolor tła obramowania i odstępów między komórkami
• ColWidth: szerokość kolumny (równa szerokości komórki plus odstępy między komórkami)
• DefaultDrawing: domyślnie rysuje wszystkie kciuki
• DesignPreview: pokazuje kciuki w Projektancie
• DragScroll: obsługuje przewijanie siatki przez przeciąganie siatki
• FileFormats: rozszerzenia nazw plików graficznych, za pomocą których filtrowane są nazwy plików
• FileNames: lista zawierająca wszystkie nazwy plików
• Folder: katalog, w którym komponent próbuje znaleźć wszystkie pliki obrazów
• ItemIndex: indeks wybranej komórki
• MarkerColor: kolor znacznika czasowego kciuka podczas ładowania
• MarkerStyle: styl czasowego znacznika kciuka podczas proces ładowania
• OnClickCell: wyĹ " wietla siÄ ™ po klikniÄ ™ ciu komórki
• OnDrawCell: wywołanie po narysowaniu komórki
• OnMeasureThumb: strzela, gdy wielkość kciuka ma być obliczona
• OnProgress: zostanie wywołany po zmianie rozmiaru obrazu na format thumb
• OnUnresolved: wywołanie, gdy nie można utworzyć kciuka, np. gdy nie znaleziono nazwy pliku
• RetainUnresolvedItems: utrzymuje puste kciuki na liście
• RowHeight: wysokość wiersza (równa wysokości komórki plus odstęp między komórkami)
• ParentBackground: rysuje (tematyczne) tło rodzica na granicy i między komórkami
• Proportional: zmienia rozmiar obrazów proporcjonalnie
• Sorted: nazwy plików są sortowane
• Stretch: rozciąga małe obrazy do rozmiaru komórki
• VirtualMode: zapobiega automatycznemu tworzeniu kciuków
• WheelScrollLines: liczba wierszy do przewinięcia za pomocą kółka myszy

Dzięki:

• InterfaceLIFT dla zdjęć pokazanych na zrzucie ekranu above
• Jak utworzyć efekt spowolnienia przewijania na polu przewijania?
• jak uzyskać wszystkie obsługiwane formaty plików z jednostki graficznej?
• czy konieczna jest konwersja String do WideString?
• poprawka dla BorderWidth > 0 w połączeniu z paskiem przewijania?

Kod jest zbyt długi, aby umieścić go tutaj, ale projekt OpenSource jest do pobrania z serwera Subversion tutaj . To jest sekcja interfejsu:

unit AwImageGrid;

interface

{$DEFINE USE_GR32}

uses
  Windows, Classes, SysUtils, Messages, Controls, Graphics, Forms, StdCtrls,
  Grids, GDIPAPI, GDIPOBJ, RTLConsts, Math, Themes
  {$IFDEF USE_GR32}, GR32, GR32_Resamplers {$ENDIF};

const
  DefCellSpacing = 5;
  DefCellWidth = 96;
  DefCellHeight = 60;
  DefColWidth = DefCellWidth + DefCellSpacing;
  DefRowHeight = DefCellHeight + DefCellSpacing;
  MinThumbSize = 4;
  MinCellSize = 8;

type
  PImageGridItem = ^TImageGridItem;
  TImageGridItem = record
    FFileName: TFileName;
    FObject: TObject;
    FImage: TGraphic;
    FThumb: TBitmap;
  end;

  PImageGridItemList = ^TImageGridItemList;
  TImageGridItemList = array[0..MaxListSize div 2] of TImageGridItem;

{ TImageGridItems
  The managing object for holding filename-thumbnail or image-thumbnail
  combinations in an array of TImageGridItem elements. When an item's image
  changes, the item's thumb is freed. When an item's filename changes, then
  the item's thumb is freed only if the item's image is unassigned. }

  TImageGridItems = class(TStrings)
  private
    FCapacity: Integer;
    FChanged: Boolean;
    FCount: Integer;
    FList: PImageGridItemList;
    FOnChanged: TNotifyEvent;
    FOnChanging: TNotifyEvent;
    FOwnsObjects: Boolean;
    FSorted: Boolean;
    procedure ExchangeItems(Index1, Index2: Integer);
    function GetImage(Index: Integer): TGraphic;
    function GetThumb(Index: Integer): TBitmap;
    procedure Grow;
    procedure InsertItem(Index: Integer; const S: String; AObject: TObject;
      AImage: TGraphic; AThumb: TBitmap);
    procedure PutImage(Index: Integer; AImage: TGraphic);
    procedure PutThumb(Index: Integer; AThumb: TBitmap);
    procedure QuickSort(L, R: Integer);
    procedure SetSorted(Value: Boolean);
  protected
    function CompareStrings(const S1, S2: String): Integer; override;
    procedure Changed; virtual;
    procedure Changing; virtual;
    function Get(Index: Integer): String; override;
    function GetCapacity: Integer; override;
    function GetCount: Integer; override;
    function GetObject(Index: Integer): TObject; override;
    procedure Put(Index: Integer; const S: String); override;
    procedure PutObject(Index: Integer; AObject: TObject); override;
    procedure PutThumbSilently(Index: Integer; AThumb: TBitmap); virtual;
    procedure SetCapacity(Value: Integer); override;
    procedure SetUpdateState(Updating: Boolean); override;
  public
    function Add(const S: String): Integer; override;
    function AddImage(const S: String; AImage: TGraphic): Integer; virtual;
    function AddItem(const S: String; AObject: TObject; AImage: TGraphic;
      AThumb: TBitmap): Integer; virtual;
    function AddObject(const S: String; AObject: TObject): Integer; override;
    function AddThumb(const S: String; AThumb: TBitmap): Integer; virtual;
    procedure AddStrings(Strings: TStrings); override;
    procedure Assign(Source: TPersistent); override;
    procedure Clear; override;
    procedure ClearThumbs; virtual;
    procedure Delete(Index: Integer); override;
    destructor Destroy; override;
    procedure Exchange(Index1, Index2: Integer); override;
    function IndexOf(const S: String): Integer; override;
    procedure Insert(Index: Integer; const S: String); override;
    procedure InsertObject(Index: Integer; const S: String;
      AObject: TObject); override;
    function Find(const S: String; var Index: Integer): Boolean;
    procedure Sort; virtual;
    property FileNames[Index: Integer]: String read Get write Put;
    property Images[Index: Integer]: TGraphic read GetImage write PutImage;
    property OnChanged: TNotifyEvent read FOnChanged write FOnChanged;
    property OnChanging: TNotifyEvent read FOnChanging write FOnChanging;
    property OwnsObjects: Boolean read FOwnsObjects write FOwnsObjects;
    property Sorted: Boolean read FSorted write SetSorted;
    property Thumbs[Index: Integer]: TBitmap read GetThumb write PutThumb;
  end;

{ TBorderControl
  A control with a system drawn border following the current theme, and an
  additional margin as implemented by TWinControl.BorderWidth. }

  TBorderControl = class(TCustomControl)
  private
    FBorderStyle: TBorderStyle;
    procedure SetBorderStyle(Value: TBorderStyle);
    procedure WMNCPaint(var Message: TWMNCPaint); message WM_NCPAINT;
    procedure CMCtl3DChanged(var Message: TMessage); message CM_CTL3DCHANGED;
  protected
    procedure CreateParams(var Params: TCreateParams); override;
    function TotalBorderWidth: Integer; virtual;
  public
    constructor Create(AOwner: TComponent); override;
    property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle
      default bsSingle;
    property BorderWidth;
  end;

{ TAnimRowScroller
  A scroll box with a vertical scroll bar and vertically stacked items with a
  fixed row height. Scrolling with the scroll bar is animated alike Windows'
  own default list box control. Scrolling is also possible by dragging the
  content with the left mouse button. }

  TAnimRowScroller = class(TBorderControl)
  private
    FAutoHideScrollBar: Boolean;
    FDragScroll: Boolean;
    FDragScrolling: Boolean;
    FDragSpeed: Single;
    FDragStartPos: Integer;
    FPrevScrollPos: Integer;
    FPrevTick: Cardinal;
    FRow: Integer;
    FRowCount: Integer;
    FRowHeight: Integer;
    FScrollingPos: Integer;
    FScrollPos: Integer;
    FWheelScrollLines: Integer;
    procedure Drag;
    function IsWheelScrollLinesStored: Boolean;
    procedure Scroll;
    procedure SetAutoHideScrollBar(Value: Boolean);
    procedure SetRow(Value: Integer);
    procedure SetRowCount(Value: Integer);
    procedure SetScrollPos(Value: Integer; Animate, Snap: Boolean);
    procedure UpdateScrollBar;
    procedure WMVScroll(var Message: TWMVScroll); message WM_VSCROLL;
  protected
    procedure CreateWnd; override;
    function DoMouseWheel(Shift: TShiftState; WheelDelta: Integer;
      MousePos: TPoint): Boolean; override;
    procedure DrawFocusRect; virtual;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X,
      Y: Integer); override;
    procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X,
      Y: Integer); override;
    procedure Resize; override;
    procedure SetRowHeight(Value: Integer); virtual;
    procedure WndProc(var Message: TMessage); override;
    property AutoHideScrollBar: Boolean read FAutoHideScrollBar
      write SetAutoHideScrollBar default True;
    property Row: Integer read FRow write SetRow default -1;
    property RowCount: Integer read FRowCount write SetRowCount;
    property RowHeight: Integer read FRowHeight write SetRowHeight
      default DefRowHeight;
    property DragScroll: Boolean read FDragScroll write FDragScroll
      default True;
    property DragScrolling: Boolean read FDragScrolling;
    property ScrollingPos: Integer read FScrollingPos;
    property WheelScrollLines: Integer read FWheelScrollLines
      write FWheelScrollLines stored IsWheelScrollLinesStored;
  public
    constructor Create(AOwner: TComponent); override;
    procedure MouseWheelHandler(var Message: TMessage); override;
    function Scrolling: Boolean;
  end;

{ TCustomImageGrid
  The base class of an image grid. It shows images from left to right, then
  from top to bottom. The number of columns is determined by the width of the
  control, possibly resulting in a vertical scroll bar. The coord size is set
  by ColWidth and RowHeight, being the sum of CellWidth resp. CellHeight plus
  CellSpacing. Each cell shows a thumb of the corresponding image. The control
  automatically starts a thumbs generating background thread when an image's
  graphic, filename or its cell size is changed. Before every such change, any
  previously created thread is terminated. Combine multiple changes by calling
  Items.BeginUpdate/Items.EndUpdate to prevent the thread from being recreated
  repeatedly. }

  TCustomImageGrid = class;

  TPath = type String;

  TDrawCellEvent = procedure(Sender: TCustomImageGrid; Index, ACol,
    ARow: Integer; R: TRect) of object;

  TImageEvent = procedure(Sender: TCustomImageGrid; Index: Integer) of object;

  TMeasureThumbEvent = procedure(Sender: TCustomImageGrid; Index: Integer;
    var AThumbWidth, AThumbHeight: Integer) of object;

  TCustomImageGrid = class(TAnimRowScroller)
  private
    FCellAlignment: TAlignment;
    FCellLayout: TTextLayout;
    FCellSpacing: Integer;
    FColCount: Integer;
    FColWidth: Integer;
    FDefaultDrawing: Boolean;
    FDesignPreview: Boolean;
    FFileFormats: TStrings;
    FFolder: TPath;
    FItemIndex: Integer;
    FItems: TImageGridItems;
    FMarkerColor: TColor;
    FMarkerStyle: TPenStyle;
    FOnClickCell: TImageEvent;
    FOnDrawCell: TDrawCellEvent;
    FOnMeasureThumb: TMeasureThumbEvent;
    FOnProgress: TImageEvent;
    FOnUnresolved: TImageEvent;
    FProportional: Boolean;
    FRetainUnresolvedItems: Boolean;
    FStretch: Boolean;
    FThumbsGenerator: TThread;
    FVirtualMode: Boolean;
    procedure DeleteUnresolvedItems;
    procedure FileFormatsChanged(Sender: TObject);
    function GetCellHeight: Integer;
    function GetCellWidth: Integer;
    function GetCount: Integer;
    function GetFileNames: TStrings;
    function GetImage(Index: Integer): TGraphic;
    function GetRowCount: Integer;
    function GetSorted: Boolean;
    function GetThumb(Index: Integer): TBitmap;
    function IsFileNamesStored: Boolean;
    procedure ItemsChanged(Sender: TObject);
    procedure ItemsChanging(Sender: TObject);
    procedure Rearrange;
    procedure SetCellAlignment(Value: TAlignment);
    procedure SetCellHeight(Value: Integer);
    procedure SetCellLayout(Value: TTextLayout);
    procedure SetCellSpacing(Value: Integer);
    procedure SetCellWidth(Value: Integer);
    procedure SetColWidth(Value: Integer);
    procedure SetDefaultDrawing(Value: Boolean);
    procedure SetDesignPreview(Value: Boolean);
    procedure SetFileFormats(Value: TStrings);
    procedure SetFileNames(Value: TStrings);
    procedure SetFolder(Value: TPath);
    procedure SetImage(Index: Integer; Value: TGraphic);
    procedure SetItemIndex(Value: Integer);
    procedure SetItems(Value: TImageGridItems);
    procedure SetMarkerColor(Value: TColor);
    procedure SetMarkerStyle(Value: TPenStyle);
    procedure SetProportional(Value: Boolean);
    procedure SetRetainUnresolvedItems(Value: Boolean);
    procedure SetSorted(Value: Boolean);
    procedure SetStretch(Value: Boolean);
    procedure SetThumb(Index: Integer; Value: TBitmap);
    procedure SetVirtualMode(Value: Boolean);
    procedure TerminateThumbsGenerator;
    procedure ThumbsUpdated(Sender: TObject);
    procedure UpdateThumbs;
    procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
    procedure WMGetDlgCode(var Message: TWMGetDlgCode); message WM_GETDLGCODE;
    procedure CMEnter(var Message: TCMEnter); message CM_ENTER;
    procedure CMExit(var Message: TCMExit); message CM_EXIT;
  protected
    procedure ChangeScale(M, D: Integer); override;
    procedure DoClickCell(Index: Integer); virtual;
    procedure DoDrawCell(Index, ACol, ARow: Integer; R: TRect); virtual;
    procedure DoMeasureThumb(Index: Integer; var AThumbWidth,
      AThumbHeight: Integer); virtual;
    procedure DoProgress(Index: Integer); virtual;
    procedure DrawFocusRect; override;
    procedure InvalidateItem(Index: Integer); virtual;
    procedure KeyDown(var Key: Word; Shift: TShiftState); override;
    procedure Loaded; override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X,
      Y: Integer); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X,
      Y: Integer); override;
    procedure Paint; override;
    procedure Resize; override;
    procedure SetRowHeight(Value: Integer); override;
    property CellAlignment: TAlignment read FCellAlignment
      write SetCellAlignment default taCenter;
    property CellHeight: Integer read GetCellHeight write SetCellHeight
      default DefCellHeight;
    property CellLayout: TTextLayout read FCellLayout write SetCellLayout
      default tlCenter;
    property CellSpacing: Integer read FCellSpacing write SetCellSpacing
      default DefCellSpacing;
    property CellWidth: Integer read GetCellWidth write SetCellWidth
      default DefCellWidth;
    property ColCount: Integer read FColCount;
    property ColWidth: Integer read FColWidth write SetColWidth
      default DefColWidth;
    property Count: Integer read GetCount;
    property DefaultDrawing: Boolean read FDefaultDrawing
      write SetDefaultDrawing default True;
    property DesignPreview: Boolean read FDesignPreview write SetDesignPreview
      default False;
    property FileFormats: TStrings read FFileFormats write SetFileFormats;
    property FileNames: TStrings read GetFileNames write SetFileNames
      stored IsFileNamesStored;
    property Folder: TPath read FFolder write SetFolder;
    property Images[Index: Integer]: TGraphic read GetImage write SetImage;
    property ItemIndex: Integer read FItemIndex write SetItemIndex default -1;
    property Items: TImageGridItems read FItems write SetItems;
    property MarkerColor: TColor read FMarkerColor write SetMarkerColor
      default clGray;
    property MarkerStyle: TPenStyle read FMarkerStyle write SetMarkerStyle
      default psDash;
    property OnClickCell: TImageEvent read FOnClickCell write FOnClickCell;
    property OnDrawCell: TDrawCellEvent read FOnDrawCell write FOnDrawCell;
    property OnMeasureThumb: TMeasureThumbEvent read FOnMeasureThumb
      write FOnMeasureThumb;
    property OnProgress: TImageEvent read FOnProgress write FOnProgress;
    property OnUnresolved: TImageEvent read FOnUnresolved write FOnUnresolved;
    property Proportional: Boolean read FProportional write SetProportional
      default True;
    property RetainUnresolvedItems: Boolean read FRetainUnresolvedItems
      write SetRetainUnresolvedItems default False;
    property RowCount: Integer read GetRowCount;
    property Sorted: Boolean read GetSorted write SetSorted default False;
    property Stretch: Boolean read FStretch write SetStretch default False;
    property Thumbs[Index: Integer]: TBitmap read GetThumb write SetThumb;
    property VirtualMode: Boolean read FVirtualMode write SetVirtualMode
      default False;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function CellRect(Index: Integer): TRect;
    function CoordFromIndex(Index: Integer): TGridCoord;
    procedure Clear; virtual;
    function MouseToIndex(X, Y: Integer): Integer;
    procedure ScrollInView(Index: Integer);
    procedure SetCellSize(ACellWidth, ACellHeight: Integer);
    procedure SetCoordSize(AColWidth, ARowHeight: Integer);
    property ParentBackground default False;
  public
    property TabStop default True;
  end;

  TAwImageGrid = class(TCustomImageGrid)
  public
    property ColCount;
    property Count;
    property Images;
    property Items;
    property RowCount;
    property Thumbs;
  published
    property Align;
    property Anchors;
    property AutoHideScrollBar;
    property BorderStyle;
    property BorderWidth;
    property CellAlignment;
    property CellHeight;
    property CellLayout;
    property CellSpacing;
    property CellWidth;
    property ClientHeight;
    property ClientWidth;
    property Color;
    property ColWidth;
    property Constraints;
    property Ctl3D;
    property DefaultDrawing;
    property DesignPreview;
    property DragCursor;
    property DragKind;
    property DragMode;
    property DragScroll;
    property Enabled;
    property FileFormats;
    property FileNames;
    property Folder;
    property ItemIndex;
    property MarkerColor;
    property MarkerStyle;
    property OnCanResize;
    property OnClick;
    property OnClickCell;
    property OnConstrainedResize;
    property OnContextPopup;
    property OnDblClick;
    property OnDockDrop;
    property OnDockOver;
    property OnDragDrop;
    property OnDragOver;
    property OnDrawCell;
    property OnEndDock;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnGetSiteInfo;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnMeasureThumb;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnMouseWheel;
    property OnMouseWheelDown;
    property OnMouseWheelUp;
    property OnProgress;
    property OnResize;
    property OnStartDock;
    property OnStartDrag;
    property OnUnDock;
    property OnUnresolved;
    property ParentBackground;
    property RetainUnresolvedItems;
    property RowHeight;
    property ParentColor;
    property ParentCtl3D;
    property ParentShowHint;
    property PopupMenu;
    property Proportional;
    property ShowHint;
    property Sorted;
    property Stretch;
    property TabOrder;
    property TabStop;
    property VirtualMode;
    property Visible;
    property WheelScrollLines;
  end;