Mehrere Hundert Images (Seitenminiaturen)

[Bjoerk]

Zitat von DeddyH:

Nur so als Gedankenspiel: Du kannst ja errechnen, wie viele Images gleichzeitig sichtbar sein können. Nehmen wir noch 2 in jede Richtung als Puffer dazu, dann merkst Du beim Scrollen, wann es Zeit wird, neue Images in Scrollrichtung zu erzeugen und zu befüllen. In der anderen Richtung kannst Du dann diejenigen, die weder in den sichtbaren noch im Puffer enthalten sind, wieder freigeben.

So (ähnlich) hab ich's nun gemacht. Ein Panel und eine Scrollbar (sbVertical, alRight) drauf. Für die Scrollbar Min und Max Position setzen. Dann nur noch die aktuelle Position weiterleiten. Position blättert ThumbImage.Height weise.

Delphi-Quellcode:

procedure TViewerForm.FormCreate(Sender: TObject);
const
  cThumbHeight = 198;
var
  I, ATop, ThumbImagesCount: integer;
begin
  [..]

  ThumbScrollBar.Max := FViewer.Count;
  FThumbImages := TThumbImages.Create(false, ThumbPanel, FViewer.Thumbs);

  if Screen.WorkAreaHeight mod cThumbHeight = 0 then
    ThumbImagesCount := Min(FViewer.Count, Screen.WorkAreaHeight div cThumbHeight)
  else
    ThumbImagesCount := Min(FViewer.Count, Screen.WorkAreaHeight div cThumbHeight + 1);

  ATop := 0;
  for I := 0 to ThumbImagesCount - 1 do
  begin
    FThumbImages.ItemsAdd;
    FThumbImages[I].Name := Format('ThumbImage%d', [I]);
    FThumbImages[I].Tag := I + 1;
    FThumbImages[I].Left := 10;
    FThumbImages[I].Top := ATop;
    FThumbImages[I].Graphic := FViewer.Thumb[I];
    FThumbImages[I].OnClick := ThumbImageClick;
    FThumbImages[I].OnMouseEnter := ThumbImageMouseEnter;
    FThumbImages[I].OnMouseLeave := ThumbImageMouseLeave;
    Inc(ATop, FThumbImages[I].Height);
  end;
end;

procedure TViewerForm.ThumbScrollBarChange(Sender: TObject);
begin
  FThumbImages.ScrollBarPosition := ThumbScrollBar.Position;
end;

procedure TViewerForm.FormMouseWheel(Sender: TObject; Shift: TShiftState;
  WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean);
begin
  ThumbScrollBar.Position :=
    RangeValue(ThumbScrollBar.Position - Sign(WheelDelta), 1, ThumbScrollBar.Max);
end;

Delphi-Quellcode:

unit uThumbImage;

interface

uses
  Classes, SysUtils, Dialogs, Controls, Graphics, Contnrs;

type
  TThumbImage = class(TGraphicControl)
  private
    FPicture: TPicture;
    FSelected: boolean;
    function GetGraphic: TGraphic;
    procedure SetGraphic(const Value: TGraphic);
    procedure SetSelected(const Value: boolean);
  protected
    procedure Paint; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property Align;
    property Anchors;
    property DragCursor;
    property DragKind;
    property DragMode;
    property Enabled;
    property Constraints;
    property ParentShowHint;
    property ShowHint;
    property Visible;
    property OnContextPopup;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDock;
    property OnEndDrag;
    property OnMouseActivate;
    property OnMouseDown;
    property OnMouseEnter;
    property OnMouseLeave;
    property OnMouseMove;
    property OnMouseUp;
    property OnStartDock;
    property OnStartDrag;
    property Color;
    property ParentColor;
    property ParentFont;
    property OnClick;
    property Graphic: TGraphic read GetGraphic write SetGraphic; // Seitenminiatur
    property Selected: boolean read FSelected write SetSelected;
    property Tag; // *** Seite = Tag
  end;

  TThumbs = class // Alle Seitenminiaturen
  private
    FItems: TObjectList;
    function GetItems(Index: integer): TBitmap;
    function GetCount: integer;
  public
    function ItemsAdd: integer;
    property Items[Index: integer]: TBitmap read GetItems; default;
    property Count: integer read GetCount;
    constructor Create;
    destructor Destroy; override;
  end;

  TThumbImages = class // MaxVisibleCount Seitenminiaturen
  private
    FItems: TObjectList;
    FParent: TWinControl;
    FThumbs: TThumbs;
    function GetItems(Index: integer): TThumbImage;
    function GetCount: integer;
    procedure SetScrollBarPosition(const Value: integer);
  public
    function ItemsAdd: integer;
    property ScrollBarPosition: integer write SetScrollBarPosition;
    property Items[Index: integer]: TThumbImage read GetItems; default;
    property Count: integer read GetCount;
    constructor Create(OwnsObjects: boolean; Parent: TWinControl; Thumbs: TThumbs);
    destructor Destroy; override;
  end;

procedure Register;

implementation

{ TThumbImage }

procedure Register;
begin
  RegisterComponents('Samples', [TThumbImage]);
end;

constructor TThumbImage.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle := ControlStyle + [csReplicatable];
  Cursor := crHandPoint;
  FPicture := TPicture.Create;
  Width := 140 + 10 + 10; // GraphicWidth + MarginLeft + MarginRight
  Height := 198 + 20 + 30; // GraphicHeight + MarginTop + MarginBottom
  Font.Name := 'Segoe UI';
  Font.Size := 8;
  Font.Color := clBlack;
  Font.Style := [fsUnderline];
  Color := clInactiveBorder;
end;

destructor TThumbImage.Destroy;
begin
  FPicture.Free;
  inherited;
end;

function TThumbImage.GetGraphic: TGraphic;
begin
  Result := FPicture.Graphic;
end;

procedure TThumbImage.SetGraphic(const Value: TGraphic);
begin
  FPicture.Assign(Value);
  Invalidate;
end;

procedure TThumbImage.SetSelected(const Value: boolean);
begin
  FSelected := Value;
  Invalidate;
end;

procedure TThumbImage.Paint;
var
  ATop, ALeft, ABottom, ARight, SumMarginsY, X, Y: integer;
  S: string;
begin
  Canvas.Brush.Color := Color;
  Canvas.FillRect(Rect(0, 0, Width, Height));

  if Tag > 0 then
  begin
    SumMarginsY := Height - FPicture.Height;
    ALeft := (Width - FPicture.Width) div 2;
    ATop := Round(0.4 * SumMarginsY);
    Canvas.Draw(ALeft, ATop, FPicture.Graphic);

    Canvas.Font.Assign(Font);
    S := IntToStr(Tag);
    X := ALeft + (FPicture.Width - Canvas.TextWidth(S)) div 2;
    Y := Round(0.6 * SumMarginsY) + FPicture.Height;
    Canvas.TextOut(X, Y, S);

    ARight := ALeft + FPicture.Width;
    ABottom := ATop + FPicture.Height;
    if FSelected then
      Canvas.Pen.Color := clHighlight
    else // Lowered;
      Canvas.Pen.Color := clBtnShadow;
    Canvas.MoveTo(ALeft, ABottom);
    Canvas.LineTo(ALeft, ATop);
    Canvas.LineTo(ARight, ATop);
    if not FSelected then
      Canvas.Pen.Color := clBtnHighlight;
    Canvas.MoveTo(ARight, ATop);
    Canvas.LineTo(ARight, ABottom);
    Canvas.LineTo(ALeft, ABottom);
  end;
end;

{ TThumbs }

constructor TThumbs.Create;
begin
  FItems := TObjectList.Create;
end;

destructor TThumbs.Destroy;
begin
  FItems.Free;
  inherited;
end;

function TThumbs.GetCount: integer;
begin
  Result := FItems.Count;
end;

function TThumbs.GetItems(Index: integer): TBitmap;
begin
  Result := TBitmap(FItems[Index]);
end;

function TThumbs.ItemsAdd: integer;
begin
  Result := FItems.Add(TBitmap.Create);
end;

{ TThumbImages }

constructor TThumbImages.Create(OwnsObjects: boolean; Parent: TWinControl; Thumbs: TThumbs);
begin
  FItems := TObjectList.Create(OwnsObjects);
  FParent := Parent;
  FThumbs := Thumbs; // Kopplung;
end;

destructor TThumbImages.Destroy;
begin
  FItems.Free;
  inherited;
end;

function TThumbImages.GetCount: integer;
begin
  Result := FItems.Count;
end;

function TThumbImages.GetItems(Index: integer): TThumbImage;
begin
  Result := TThumbImage(FItems[Index]);
end;

function TThumbImages.ItemsAdd: integer;
begin
  Result := FItems.Add(TThumbImage.Create(FParent));
  Items[Result].Parent := FParent;
end;

procedure TThumbImages.SetScrollBarPosition(const Value: integer);
var
  I, Index, Tag: integer;
begin
  if FThumbs.Count > Count then // else nothing to do
    if (Value >= 1) and (Value <= FThumbs.Count) then // = ScrollBarPosition.Min .. ScrollBarPosition.Max
      for I := 0 to Count - 1 do
      begin
        Index := I + Value - 1; // Null basiert (Items);
        Tag := Index + 1; // Eins basiert (Seitennummer);
        if Index < FThumbs.Count then
        begin
          Items[I].Tag := Tag;
          Items[I].Graphic := FThumbs[Index];
        end
        else
        begin
          Items[I].Tag := 0;
          Items[I].Invalidate;
        end;
      end;
end;

end.