lbdbscrollbar.pas

天涯進銷存系統

unit LBDBScrollBar;

interface

uses
   Windows, Messages, SysUtils, Classes, Graphics, ExtCtrls, Controls,
   Buttons, LBCtrls, Db;

Type
  TScrButtonState = (sbPrior, sbNext);

  TLBScrollButton = class;
  BtnClick = procedure (Sender: TObject; Button: TLBScrollButton) of object;

  TLBScrollButton = class (TLBButton)
  private
    FButtonState: TScrButtonState;
    FBtnClick: BtnClick;
    FRepeatTimer: TTimer;
    FLineColor:TColor;
    procedure TimerExpired(Sender: TObject);
  protected
    procedure Paint; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); override;
  published
    property ButtonState: TScrButtonState read FButtonState write FButtonState;
    property OnClick : BtnClick read  FBtnClick write FBtnClick;
  published
    property LineColor: TColor read FLineColor write FLineColor;
  end;

  TLBDBScrollBar = class (TCustomPanel)
  private
    FPriorButton: TLBScrollButton;
    FNextButton: TLBScrollButton;
    FDataSource: TDataSet;
    FLineColor: TColor;
    FDownFontColor: TColor;
  protected
    procedure Paint; override;
    procedure ButtonClick(Sender: TObject; Button: TLBScrollButton);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property Align;
    property Alignment;
    property Anchors;
    property AutoSize;
    property BiDiMode;
    property BorderWidth;
    property BorderStyle;
    property Color;
    property LineColor: TColor read FLineColor write FLineColor;
    property DownFontColor: TColor read FDownFontColor write FDownFontColor;
    property Constraints;
    property Ctl3D;
    property UseDockManager default True;
    property DockSite;
    property DragCursor;
    property DragKind;
    property DragMode;
    property Enabled;
    property FullRepaint;
    property Font;
    property Locked;
    property ParentBiDiMode;
    property ParentBackground;
    property ParentColor;
    property ParentCtl3D;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property TabOrder;
    property TabStop;
    property Visible;
    property OnCanResize;
    property OnClick;
    property OnConstrainedResize;
    property OnContextPopup;
    property OnDockDrop;
    property OnDockOver;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDock;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnGetSiteInfo;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnResize;
    property OnStartDock;
    property OnStartDrag;
    property OnUnDock;
    property DataSource: TDataSet read FDataSource write FDataSource;
  end;
  
implementation

constructor TLBScrollButton.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Height:=17;
//  Width:=1;
  FLineColor:=clBackground;
end;

destructor TLBScrollButton.Destroy;
begin
  if FRepeatTimer<>nil then
    FRepeatTimer.Enabled:=False;
    FRepeatTimer.Free;
  inherited Destroy;
end;

procedure TLBScrollButton.TimerExpired(Sender: TObject);
begin 
  FRepeatTimer.Interval := 100;
  if (FState = bsDown) and MouseCapture then
  begin
    try
      FBtnClick(Sender, Self);
    except
      FRepeatTimer.Enabled := False;
      raise;
    end;
  end;
end;

procedure TLBScrollButton.MouseDown(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer);
begin
  inherited MouseDown (Button, Shift, X, Y);
  if Button=mbLeft then
  begin
    FBtnClick(nil, Self);
    if FRepeatTimer = nil then
       FRepeatTimer := TTimer.Create(Self);

    FRepeatTimer.OnTimer := TimerExpired;
    FRepeatTimer.Interval := 100;
    FRepeatTimer.Enabled  := True;
  end;  
end;

procedure TLBScrollButton.MouseUp(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); 
begin
  inherited MouseUp (Button, Shift, X, Y);
  if FRepeatTimer <> nil then
    FRepeatTimer.Enabled  := False;
end;      

procedure TLBScrollButton.Paint;
var
  R: TRect;
begin
  Font.Name:='Marlett';
  Font.Size:=9;
  if FButtonState= sbPrior then
  Caption:='t'
  else
  if FButtonState= sbNext then
  Caption:='u';
  inherited Paint;
  R:=Rect(0, 0, Width, Height);
  Canvas.Brush.Color:=FLineColor;
  Canvas.FrameRect(R);
  R:=Rect(1, 1, Width-1, Height-1);
  Canvas.Brush.Color:=clWhite;
  Canvas.FrameRect(R);
end;

constructor TLBDBScrollBar.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Height:=121;
  Width:=18;
  Color:=$00FFF3EF;
  FLineColor:=clBackground;
  BevelOuter:=bvNone;
  FPriorButton:=TLBScrollButton.Create(Self);
  FPriorButton.OnClick:=ButtonClick;
  FNextButton:=TLBScrollButton.Create(Self);
  FNextButton.OnClick:=ButtonClick;
end;

destructor TLBDBScrollBar.Destroy;
begin
  inherited Destroy;
end;

procedure TLBDBScrollBar.Paint;
var
  R: TRect;
begin
  R:=Rect(0, 0, Width, Height);
  with Canvas do
  begin
    Pen.Color:=Color;
    Brush.Color:=Color;
    FillRect(R);
    Brush.Color := FLineColor;
    FrameRect(R);
  end;
  with FPriorButton do
  begin
    LineColor:=Self.FLineColor;
    Parent:=Self;
    ButtonState:=sbPrior;
    Top:=Top;
    width:=Self.Width;
  end;
  with FNextButton do
  begin
    LineColor:=Self.FLineColor;
    Parent:=Self;
    ButtonState:=sbNext;
    Top:=Self.Height-FNextButton.Height;
    width:=Self.Width;
  end;
  R:=Rect(0, 0, Width, FPriorButton.Height);
  Canvas.Brush.Color := FLineColor;
  Canvas.FrameRect(R);
  R:=Rect(0, FNextButton.Top, Width, Height);
  Canvas.Brush.Color := FLineColor;
  Canvas.FrameRect(R);
end;

procedure TLBDBScrollBar.ButtonClick(Sender: TObject; Button: TLBScrollButton);
begin
  if (DataSource <> nil) and (DataSource.State <> dsInactive) then
  begin
    if not (csDesigning in ComponentState)  then
    with DataSource do
    begin
      if Button.ButtonState=sbPrior then  Prior
      else
      if Button.ButtonState=sbNext then  Next;
    end;
  end;
end;


end.