fctrackbar.pas

一套及时通讯的原码

{
//
// Components : TfcTrackBar
//
// Copyright (c) 2003 by Woll2Woll Software
//
}
unit fctrackbar;

interface

{$i fcIfdef.pas}
uses
  Consts, Messages, Windows, SysUtils, CommCtrl, Classes, Controls, Forms, Menus,
  Graphics, StdCtrls, ImgList, ExtCtrls, ComCtrls,
  dbctrls, db, fcpanel,
  {$ifdef fcDelphi7Up}
   themes, uxtheme,
  {$endif}

  {$ifdef ThemeManager}
  thememgr, themesrv, uxtheme,
  {$endif}

  fccommon;
type

{ TfcTrackBar }

  TfcTrackBarOrientation = (trfcHorizontal, trfcVertical);
  TfcTickMark = (tmfcBottomRight, tmfcTopLeft, tmfcBoth);
  TfcTickStyle = (tsfcNone, tsfcAuto, tsfcManual);


  TfcTrackBarTextPosition = (tbtLeft, tbtRight, tbtTop, tbtBottom);
  TfcTrackBar = class;

  TfcTrackBarText = class(TPersistent)
  private
     FShowText: boolean;
     FPosition: TfcTrackBarTextPosition;
     FOffsetX, FOffsetY: integer;
     FDisplayFormat: string;
     FTickLabelFrequency: integer;
     FTickDisplayFormat: string;
     procedure SetFont(Value: TFont);
     function GetFont: TFont;
     procedure SetPosition(Value: TfcTrackBarTextPosition);
     procedure SetOffsetX(Value: integer);
     procedure SetOffsetY(Value: integer);
     procedure SetDisplayFormat(Value: String);
     procedure  SetShowText(Value: boolean);
     procedure SetTickLabelFrequency(Value: integer);
     procedure SetTickDisplayFormat(Value: string);
  public
     Owner: TfcTrackBar;
     constructor Create(AOwner: TComponent);
  published
     property Position : TfcTrackBarTextPosition read FPosition write SetPosition default tbtLeft;
     property OffsetX: integer read FOffsetX write SetOffsetX default 0;
     property OffsetY: integer read FOffsetY write SetOffsetY default 0;
     property Font: TFont read GetFont write SetFont;
     property DisplayFormat: string read FDisplayFormat write SetDisplayFormat;
     property ShowText: boolean read FShowText write SetShowText default False;
     property TickLabelFrequency: integer read FTickLabelFrequency write SetTickLabelFrequency default 0;
     property TickDisplayFormat: string read FTickDisplayFormat write SetTickDisplayFormat;
  end;

  TfcTrackIcon = class(TGraphicControl)
  private
     TrackBmp: TBitmap;
     FOnEndDrag: TNotifyEvent;
     procedure MouseLoop_Drag(X, Y: Integer);

  protected
     DraggingThumb: boolean;

     procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
       X, Y: Integer); override;
     Procedure Paint; override;
     procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
  public
     TrackBar: TfcTrackBar;
     constructor Create(AOwner: TComponent); override;
     destructor Destroy; override;

  published
     property OnEndDrag: TNotifyEvent read FOnEndDrag write FOnEndDrag;
  end;

  TfcTrackRepeatTimer = class (TTimer)
  private
     Increment: Double;
  end;

  TfcDrawTickTextEvent =
     procedure (Sender: TObject; TickValue: Double;
                var ATickText: string; var ARect: TRect;
                var DoDefault: boolean) of object;

  TfcTrackBar = class(TfcCustomPanel) //WinControl)
//  TfcTrackBar = class(TWinControl)
  private
    FTextAttributes: TfcTrackBarText;
    FOrientation: TfcTrackBarOrientation;
    FTickMarks: TfcTickMark;
    FTickStyle: TfcTickStyle;
    FIncrement: Double;
    FPageSize: Integer;
    FThumbLength: Integer;
    FThumbThickness: Integer;
    FSliderVisible: Boolean;
    FMin: Double;
    FMax: Double;
    FFrequency: Double;
    FPosition: Double;
    FSelStart: Double;
    FSelEnd: Double;
    FOnChange: TNotifyEvent;
    FDataLink: TFieldDataLink;
    TrackButton: TfcTrackIcon;
    FTrackThumbIcon: TBitmap;
    FThumbTrackSeparation: integer;
    FThumbColor: TColor;
    FTrackColor: TColor;
    FTrackPartialFillColor: TColor;
    FRepeatTimer: TfcTrackRepeatTimer;
    FSpacingLeftTop: integer;
    FSpacingRightBottom: integer;
    FSpacingEdgeTrackbar: integer;
    FReadOnly: boolean;
    FInverted: boolean;
    FOnDrawTickText: TfcDrawTickTextEvent;
    FDisableThemes: boolean;

    SkipEdit: boolean;
    procedure PositionChanging; virtual;
    procedure TimerExpired(Sender: TObject); virtual;
    procedure SetThumbColor(val: TColor);
    function GetThumbLength: Integer;
    function GetThumbThickness: Integer;
    procedure SetOrientation(Value: TfcTrackBarOrientation);
    procedure SetParams(APosition, AMin, AMax: Double);
    procedure SetPosition(Value: Double);
    procedure SetMin(Value: Double);
    procedure SetMax(Value: Double);
    procedure SetFrequency(Value: Double);
    procedure SetTickStyle(Value: TfcTickStyle);
    procedure SetTickMarks(Value: TfcTickMark);
    procedure SetIncrement(Value: Double);
    procedure SetPageSize(Value: Integer);
    procedure SetThumbLength(Value: Integer);
    procedure SetThumbThickness(Value: Integer);
    procedure SetSliderVisible(Value: Boolean);
    procedure SetSelStart(Value: Double);
    procedure SetSelEnd(Value: Double);
    procedure UpdateSelection;
    procedure UpdateFromButton(Sender: TObject);
    procedure CNHScroll(var Message: TWMHScroll); message CN_HSCROLL;
    procedure CNVScroll(var Message: TWMVScroll); message CN_VSCROLL;
    procedure WMEraseBkGnd(var Message: TWMEraseBkGnd); message WM_ERASEBKGND;
    procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
    function GetDataField: string;
    function GetDataSource: TDataSource;
    procedure SetDataField(const Value: string);
    procedure SetDataSource(Value: TDataSource);
    function GetField: TField;
    procedure SetThumbIcon(Value: TBitmap);
    Function GetThumbIcon: TBitmap;
    procedure WMGetDlgCode(var Message: TWMGetDlgCode); message WM_GETDLGCODE;
    procedure WMSetFocus(var Message: TWMSetFocus); message WM_SETFOCUS;
    procedure CMEnter(var Message: TCMEnter); message CM_ENTER;
    procedure CMExit(var Message: TCMExit); message CM_EXIT;
    procedure CMGetDataLink(var Message: TMessage); message CM_GETDATALINK;
    procedure SetSpacingLeftTop(Value: integer);
    procedure SetSpacingRightBottom(Value: integer);
    procedure SetSpacingEdgeTrackbar(Value: integer);
    Function GetDBValue: Double;
    procedure SetTrackColor(Value: TColor);
    procedure SetTrackPartialFillColor(Value: TColor);

  protected
    procedure DrawTickText(TickValue: Double; TickText: string; ARect: TRect); virtual;
    procedure UpdateRecord;
    procedure UpdateData(Sender: TObject); virtual;
    function EffectiveReadOnly: Boolean; virtual;
    function EditCanModify: Boolean; virtual;
    procedure PaintThumb(ALeft, ATop: integer); virtual;
    function getPosition: Double; virtual;
    function GetTrackBarRect: TRect;
    procedure CreateParams(var Params: TCreateParams); override;
    procedure CreateWnd; override;
    procedure DestroyWnd; override;
    procedure Changed; dynamic;
    procedure DataChange(Sender: TObject); virtual;
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    procedure Paint; override;
    function ValToPixel(Val: Extended): integer;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
                                  X, Y: Integer); override;
    procedure KeyDown(var Key: word; Shift: TShiftState); override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
//    procedure UpdateSelection;
//    procedure SetTick(Value: Integer);
    property DataLink: TFieldDataLink read FDataLink;
    property Field: TField read GetField;
  published
    property DisableThemes : boolean read FDisableThemes write FDisableThemes default False;
    property TextAttributes: TfcTrackBarText read FTextAttributes write FTextAttributes;
    property TrackThumbIcon: TBitmap read GetThumbIcon write SetThumbIcon;
    property ThumbColor: TColor read FThumbColor write SetThumbColor;
    property SpacingLeftTop: integer read FSpacingLeftTop write SetSpacingLeftTop default 5;
    property SpacingRightBottom: integer read FSpacingRightBottom write SetSpacingRightBottom default 5;
    property SpacingEdgeTrackbar: integer read FSpacingEdgeTrackbar write SetSpacingEdgeTrackbar default 2;
    property ReadOnly: boolean read FReadOnly write FReadOnly;
    property Inverted: boolean read FInverted write FInverted default False;
    property TrackColor: TColor read FTrackColor write SetTrackColor default clWhite;
    property TrackPartialFillColor: TColor read FTrackPartialFillColor write SetTrackPartialFillColor default clNone;

    property Align;
    property Anchors;
    property BorderWidth;
    property Ctl3D;
    property DragCursor;
    property DragKind;
    property DragMode;
    property Enabled;
    property Constraints;
    property Increment: Double read FIncrement write SetIncrement;
    property Max: Double read FMax write SetMax;
    property Min: Double read FMin write SetMin;
    property Orientation: TfcTrackBarOrientation read FOrientation write SetOrientation default trfcHorizontal;
    property ParentCtl3D;
    property ParentShowHint;
    property PageSize: Integer read FPageSize write SetPageSize default 2;
    property PopupMenu;
    property Frequency: Double read FFrequency write SetFrequency;
    property Position: Double read GetPosition write SetPosition;
    property SliderVisible: Boolean read FSliderVisible write SetSliderVisible default True;
    property SelEnd: Double read FSelEnd write SetSelEnd;
    property SelStart: Double read FSelStart write SetSelStart;
    property ShowHint;
    property TabOrder;
    property TabStop default True;
    property ThumbLength: Integer read GetThumbLength write SetThumbLength default 20;
    property ThumbThickness: Integer read GetThumbThickness write SetThumbThickness default 10;
    property TickMarks: TfcTickMark read FTickMarks write SetTickMarks default tmfcBottomRight;
    property TickStyle: TfcTickStyle read FTickStyle write SetTickStyle default tsfcAuto;
    property Visible;
    property OnContextPopup;
    property OnDrawTickText : TfcDrawTickTextEvent read FOnDrawTickText write FOnDrawTickText;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDock;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnStartDock;
    property OnStartDrag;
    property DataField: string read GetDataField write SetDataField;
    property DataSource: TDataSource read GetDataSource write SetDataSource;
  end;


implementation

const
  MaxAutoTicks = 10000;
  InitRepeatPause = 400;  { pause before repeat timer (ms) }
  RepeatPause     = 100;  { pause before hint window displays (ms)}

constructor TfcTrackIcon.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle := ControlStyle + [csReplicatable];
  TrackBar:= AOwner as TfcTrackBar;
  TrackBmp:= TBitmap.create;
  ControlStyle:= ControlStyle - [csOpaque];
end;

destructor TfcTrackIcon.Destroy;
begin
   TrackBmp.Free;
   TrackBmp:= nil;
   inherited Destroy;
end;

procedure TfcTrackIcon.WMPaint(var Message: TWMPaint);
begin
   inherited;
//   message.result:=1;
end;

Procedure TfcTrackIcon.Paint;
begin
   exit;
end;


   function TfcTrackBar.ValToPixel(Val: Extended): Integer;
   var PixelVal: Extended;
       tr: TRect;
   begin
      tr:= GetTrackBarRect;
      if orientation = trfcHorizontal then
      begin
         if Inverted then
           PixelVal:= (tr.Right-tr.left) - (tr.Right-tr.Left)/
                   (Max-Min) * (Val-Min)
         else
           PixelVal:= (tr.Right-tr.Left)/
                   (Max-Min) * (Val-Min)
      end
      else begin
        if Inverted then
          PixelVal:= (tr.Bottom - tr.Top) - (tr.Bottom-tr.Top)/
                     (Max-Min) * (Val-Min)
        else
          PixelVal:= (tr.Bottom-tr.Top)/
                     (Max-Min) * (Val-Min);
      end;
      result:=Trunc(PixelVal);
   end;

procedure TfcTrackIcon.MouseLoop_Drag(X, Y: Integer);
var ACursor: TPoint;
    Msg: TMsg;
    FirstTime: boolean;
    CaptureHandle: HWND;
    DragOffset: integer;

   function PixelToVal(PixelVal: integer): Extended;
   var val : Extended;
       tr: TRect;
   begin
      with TrackBar do
      begin
         tr:= GetTrackBarRect;
         if TrackBar.orientation = trfcHorizontal then
         begin
            if Inverted then
            begin
               val:= Min + (Max-Min) / (tr.Right-tr.Left) * PixelVal;
               val:= (Max+Min) - val;
            end
            else
               val:= Min + (Max-Min) / (tr.Right-tr.Left) * PixelVal
         end
         else begin
            if Inverted then
            begin
              Val:= Min + (Max-Min) / (tr.Bottom-tr.top) * PixelVal;
              val:= (Max+Min) - val;
            end
            else
              val:= Min + (Max-Min) / (tr.Bottom-tr.top) * PixelVal
         end;
      end;
      result:=val;
   end;

   procedure SetValue(PixelVal: integer);
   var val: Double;
       valStr: string;
   begin
//       val:= Trunc(PixelToVal(PixelVal));
//       val:= Round(PixelToVal(PixelVal));
       val:= Trackbar.Increment*Round(PixelToVal(PixelVal)/Trackbar.Increment);
       if (val<TrackBar.Min) then
          val:= TrackBar.Min
       else if (val>TrackBar.Max) then
          val:= TrackBar.Max;
       valstr:= floattostr(val);
       TrackBar.Position:=val;
   end;


begin
   CaptureHandle:= GetParentForm(self).Handle;
   SetCapture(CaptureHandle);
   FirstTime:= True;
   DragOffset:=0; // Make compiler happy


   try
      while GetCapture = CaptureHandle do
      begin
         GetCursorPos(ACursor);
         ACursor := ScreenToClient(ACursor);

         case Integer(GetMessage(Msg, 0, 0, 0)) of
           -1: Break;
           0: begin PostQuitMessage (Msg.WParam); Break; end;