Registriert seit: 28. Feb 2011
Ort: Mannheim
1.384 Beiträge
Delphi 10.4 Sydney
|
AW: Mehrere Hundert Images (Seitenminiaturen)
13. Nov 2016, 09:26
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.
|