组件（类似于轨迹栏）输入一系列值

时间：2010-12-08 12:58:33

标签： delphi components trackbar

我需要一个用于输入范围的组件。我正在考虑一个带有两个标记的轨道栏。是否存在用于此目的的“原生Delphi”组件或可以轻松模拟它的组件？

5 个答案:

答案 0 :(得分：28)

我几分钟后写了这个：

unit RangeSelector;

interface

uses
  SysUtils, Windows, Messages, Graphics, Classes, Controls, UxTheme, Dialogs;

type
  TRangeSelectorState = (rssNormal, rssDisabled, rssThumb1Hover, rssThumb1Down, rssThumb2Hover, rssThumb2Down, rssBlockHover, rssBlockDown);

  TRangeSelector = class(TCustomControl)
  private
    { Private declarations }
    FBuffer: TBitmap;
    FMin,
    FMax,
    FSelStart,
    FSelEnd: real;
    FTrackPos,
    FSelPos,
    FThumbPos1,
    FThumbPos2: TRect;
    FState: TRangeSelectorState;
    FDown: boolean;
    FPrevX,
    FPrevY: integer;
    FOnChange: TNotifyEvent;
    FDblClicked: Boolean;
    FThumbSize: TSize;
    procedure SwapBuffers;
    procedure SetMin(Min: real);
    procedure SetMax(Max: real);
    procedure SetSelStart(SelStart: real);
    procedure SetSelEnd(SelEnd: real);
    function GetSelLength: real;
    procedure UpdateMetrics;
    procedure SetState(State: TRangeSelectorState);
    function DeduceState(const X, Y: integer; const Down: boolean): TRangeSelectorState;
    function BarWidth: integer; inline;
    function LogicalToScreen(const LogicalPos: real): real;
    procedure UpdateThumbMetrics;
  protected
    { Protected declarations }
    procedure Paint; override;
    procedure WndProc(var Message: TMessage); override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X: Integer; Y: Integer); override;
    procedure MouseMove(Shift: TShiftState; X: Integer; Y: Integer); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X: Integer; Y: Integer); override;
    procedure MouseLeave(Sender: TObject);
    procedure DblClick; override;
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    { Published declarations }
    property Anchors;
    property Min: real read FMin write SetMin;
    property Max: real read FMax write SetMax;
    property SelStart: real read FSelStart write SetSelStart;
    property SelEnd: real read FSelEnd write SetSelEnd;
    property SelLength: real read GetSelLength;
    property Enabled;
    property Visible;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
  end;

procedure Register;

implementation

uses Math;

procedure Register;
begin
  RegisterComponents('Rejbrand 2009', [TRangeSelector]);
end;

function IsIntInInterval(x, xmin, xmax: integer): boolean; inline;
begin
  IsIntInInterval := (xmin <= x) and (x <= xmax);
end;

function PointInRect(const X, Y: integer; const Rect: TRect): boolean; inline;
begin
  PointInRect := IsIntInInterval(X, Rect.Left, Rect.Right) and
                 IsIntInInterval(Y, Rect.Top, Rect.Bottom);
end;

function IsRealInInterval(x, xmin, xmax: extended): boolean; inline;
begin
  IsRealInInterval := (xmin <= x) and (x <= xmax);
end;

{ TRangeSelector }

function TRangeSelector.BarWidth: integer;
begin
  result := Width - 2*FThumbSize.cx;
end;

constructor TRangeSelector.Create(AOwner: TComponent);
begin
  inherited;
  FBuffer := TBitmap.Create;
  FMin := 0;
  FMax := 100;
  FSelStart := 20;
  FSelEnd := 80;
  FDown := false;
  FPrevX := -1;
  FPrevY := -1;
  FDblClicked := false;
end;

procedure TRangeSelector.UpdateThumbMetrics;
var
  theme: HTHEME;
const
  DEFAULT_THUMB_SIZE: TSize = (cx: 12; cy: 20);
begin
  FThumbSize := DEFAULT_THUMB_SIZE;
  if UxTheme.UseThemes then
  begin
    theme := OpenThemeData(Handle, 'TRACKBAR');
    if theme <> 0 then
      try
        GetThemePartSize(theme, FBuffer.Handle, TKP_THUMBTOP, TUTS_NORMAL, nil, TS_DRAW, FThumbSize);
      finally
        CloseThemeData(theme);
      end;
  end;
end;

destructor TRangeSelector.Destroy;
begin
  FBuffer.Free;
  inherited;
end;

function TRangeSelector.GetSelLength: real;
begin
  result := FSelEnd - FSelStart;
end;

function TRangeSelector.LogicalToScreen(const LogicalPos: real): real;
begin
  result := FThumbSize.cx + BarWidth * (LogicalPos - FMin) / (FMax - FMin)
end;

procedure TRangeSelector.DblClick;
var
  str: string;
begin
  FDblClicked := true;
  case FState of
    rssThumb1Hover, rssThumb1Down:
      begin
        str := FloatToStr(FSelStart);
        if InputQuery('Initial value', 'Enter new initial value:', str) then
          SetSelStart(StrToFloat(str));
      end;
    rssThumb2Hover, rssThumb2Down:
      begin
        str := FloatToStr(FSelEnd);
        if InputQuery('Final value', 'Enter new final value:', str) then
          SetSelEnd(StrToFloat(str));
      end;
  end;
end;

function TRangeSelector.DeduceState(const X, Y: integer; const Down: boolean): TRangeSelectorState;
begin
  result := rssNormal;

  if not Enabled then
    Exit(rssDisabled);

  if PointInRect(X, Y, FThumbPos1) then
    if Down then
      result := rssThumb1Down
    else
      result := rssThumb1Hover

  else if PointInRect(X, Y, FThumbPos2) then
    if Down then
      result := rssThumb2Down
    else
      result := rssThumb2Hover

  else if PointInRect(X, Y, FSelPos) then
    if Down then
      result := rssBlockDown
    else
      result := rssBlockHover;


end;

procedure TRangeSelector.MouseDown(Button: TMouseButton; Shift: TShiftState; X,
  Y: Integer);
begin
  inherited;
  if FDblClicked then
  begin
    FDblClicked := false;
    Exit;
  end;
  FDown := Button = mbLeft;
  SetState(DeduceState(X, Y, FDown));
end;

procedure TRangeSelector.MouseLeave(Sender: TObject);
begin
  if Enabled then
    SetState(rssNormal)
  else
    SetState(rssDisabled);
end;

procedure TRangeSelector.MouseMove(Shift: TShiftState; X, Y: Integer);
begin
  inherited;
  if FState = rssThumb1Down then
    SetSelStart(FSelStart + (X - FPrevX) * (FMax - FMin) / BarWidth)
  else if FState = rssThumb2Down then
    SetSelEnd(FSelEnd + (X - FPrevX) * (FMax - FMin) / BarWidth)
  else if FState = rssBlockDown then
  begin
    if IsRealInInterval(FSelStart + (X - FPrevX) * (FMax - FMin) / BarWidth, FMin, FMax) and
       IsRealInInterval(FSelEnd + (X - FPrevX) * (FMax - FMin) / BarWidth, FMin, FMax) then
    begin
      SetSelStart(FSelStart + (X - FPrevX) * (FMax - FMin) / BarWidth);
      SetSelEnd(FSelEnd + (X - FPrevX) * (FMax - FMin) / BarWidth);
    end;
  end
  else
    SetState(DeduceState(X, Y, FDown));

  FPrevX := X;
  FPrevY := Y;
end;

procedure TRangeSelector.MouseUp(Button: TMouseButton; Shift: TShiftState; X,
  Y: Integer);
begin
  inherited;
  FDown := false;
  SetState(DeduceState(X, Y, FDown));
end;

procedure TRangeSelector.Paint;
var
  theme: HTHEME;
begin
  inherited;

  FBuffer.Canvas.Brush.Color := Color;
  FBuffer.Canvas.FillRect(ClientRect);

  if UxTheme.UseThemes then
  begin

    theme := OpenThemeData(Handle, 'TRACKBAR');
    if theme <> 0 then
      try

        DrawThemeBackground(theme, FBuffer.Canvas.Handle, TKP_TRACK, TRS_NORMAL, FTrackPos, nil);

        case FState of
          rssDisabled:
            DrawThemeBackground(theme, FBuffer.Canvas.Handle, TKP_THUMB, TUS_DISABLED, FSelPos, nil);
          rssBlockHover:
            DrawThemeBackground(theme, FBuffer.Canvas.Handle, TKP_THUMB, TUS_HOT, FSelPos, nil);
          rssBlockDown:
            DrawThemeBackground(theme, FBuffer.Canvas.Handle, TKP_THUMB, TUS_PRESSED, FSelPos, nil);
        else
          DrawThemeBackground(theme, FBuffer.Canvas.Handle, TKP_THUMB, TUS_NORMAL, FSelPos, nil);
        end;


        case FState of
          rssDisabled:
            DrawThemeBackground(theme, FBuffer.Canvas.Handle, TKP_THUMBBOTTOM, TUBS_DISABLED, FThumbPos1, nil);
          rssThumb1Hover:
            DrawThemeBackground(theme, FBuffer.Canvas.Handle, TKP_THUMBBOTTOM, TUBS_HOT, FThumbPos1, nil);
          rssThumb1Down:
            DrawThemeBackground(theme, FBuffer.Canvas.Handle, TKP_THUMBBOTTOM, TUBS_PRESSED, FThumbPos1, nil);
        else
          DrawThemeBackground(theme, FBuffer.Canvas.Handle, TKP_THUMBBOTTOM, TUBS_NORMAL, FThumbPos1, nil);
        end;

        case FState of
          rssDisabled:
            DrawThemeBackground(theme, FBuffer.Canvas.Handle, TKP_THUMBTOP, TUTS_DISABLED, FThumbPos2, nil);
          rssThumb2Hover:
            DrawThemeBackground(theme, FBuffer.Canvas.Handle, TKP_THUMBTOP, TUTS_HOT, FThumbPos2, nil);
          rssThumb2Down:
            DrawThemeBackground(theme, FBuffer.Canvas.Handle, TKP_THUMBTOP, TUTS_PRESSED, FThumbPos2, nil);
        else
          DrawThemeBackground(theme, FBuffer.Canvas.Handle, TKP_THUMBTOP, TUTS_NORMAL, FThumbPos2, nil);
        end;

      finally
        CloseThemeData(theme);
      end;

  end

  else

  begin

    DrawEdge(FBuffer.Canvas.Handle, FTrackPos, EDGE_SUNKEN, BF_RECT);

    FBuffer.Canvas.Brush.Color := clHighlight;
    FBuffer.Canvas.FillRect(FSelPos);

    case FState of
      rssDisabled:
        DrawEdge(FBuffer.Canvas.Handle, FSelPos, EDGE_BUMP, BF_RECT or BF_MONO);
      rssBlockHover:
        DrawEdge(FBuffer.Canvas.Handle, FSelPos, EDGE_RAISED, BF_RECT);
      rssBlockDown:
        DrawEdge(FBuffer.Canvas.Handle, FSelPos, EDGE_SUNKEN, BF_RECT);
    else
      DrawEdge(FBuffer.Canvas.Handle, FSelPos, EDGE_ETCHED, BF_RECT);
    end;

    case FState of
      rssDisabled:
        DrawEdge(FBuffer.Canvas.Handle, FThumbPos1, EDGE_BUMP, BF_RECT or BF_MONO);
      rssThumb1Hover:
        DrawEdge(FBuffer.Canvas.Handle, FThumbPos1, EDGE_RAISED, BF_RECT);
      rssThumb1Down:
        DrawEdge(FBuffer.Canvas.Handle, FThumbPos1, EDGE_SUNKEN, BF_RECT);
    else
      DrawEdge(FBuffer.Canvas.Handle, FThumbPos1, EDGE_ETCHED, BF_RECT);
    end;

    case FState of
      rssDisabled:
        DrawEdge(FBuffer.Canvas.Handle, FThumbPos2, EDGE_BUMP, BF_RECT or BF_MONO);
      rssThumb2Hover:
        DrawEdge(FBuffer.Canvas.Handle, FThumbPos2, EDGE_RAISED, BF_RECT);
      rssThumb2Down:
        DrawEdge(FBuffer.Canvas.Handle, FThumbPos2, EDGE_SUNKEN, BF_RECT);
    else
      DrawEdge(FBuffer.Canvas.Handle, FThumbPos2, EDGE_ETCHED, BF_RECT);
    end;

  end;

  SwapBuffers;
end;

procedure TRangeSelector.UpdateMetrics;
begin
  UpdateThumbMetrics;
  FBuffer.SetSize(Width, Height);
  FTrackPos := Rect(FThumbSize.cx, FThumbSize.cy + 2, Width - FThumbSize.cx, Height - FThumbSize.cy - 2);
  FSelPos := Rect(round(LogicalToScreen(FSelStart)),
                  FTrackPos.Top,
                  round(LogicalToScreen(FSelEnd)),
                  FTrackPos.Bottom);
  with FThumbPos1 do
  begin
    Top := 0;
    Left := round(LogicalToScreen(FSelStart) - FThumbSize.cx / 2);
    Right := Left + FThumbSize.cx;
    Bottom := Top + FThumbSize.cy;
  end;
  with FThumbPos2 do
  begin
    Top := Self.Height - FThumbSize.cy;
    Left := round(LogicalToScreen(FSelEnd) - FThumbSize.cx / 2);
    Right := Left + FThumbSize.cx;
    Bottom := Top + FThumbSize.cy;
  end;
end;

procedure TRangeSelector.WndProc(var Message: TMessage);
begin
  inherited;
  case Message.Msg of
    WM_SIZE:
      UpdateMetrics;
  end;
end;

procedure TRangeSelector.SetMax(Max: real);
begin
  if FMax <> Max then
  begin
    FMax := Max;
    UpdateMetrics;
    Paint;
  end;
end;

procedure TRangeSelector.SetMin(Min: real);
begin
  if FMin <> Min then
  begin
    FMin := Min;
    UpdateMetrics;
    Paint;
  end;
end;

procedure TRangeSelector.SetSelEnd(SelEnd: real);
begin
  if (FSelEnd <> SelEnd) and IsRealInInterval(SelEnd, FMin, FMax) then
  begin
    FSelEnd := SelEnd;
    if FSelStart > FSelEnd then
      FSelStart := FSelEnd;
    UpdateMetrics;
    Paint;
    if Assigned(FOnChange) then
      FOnChange(Self);
  end;
end;

procedure TRangeSelector.SetSelStart(SelStart: real);
begin
  if (FSelStart <> SelStart) and IsRealInInterval(SelStart, FMin, FMax) then
  begin
    FSelStart := SelStart;
    if FSelStart > FSelEnd then
      FSelEnd := FSelStart;
    UpdateMetrics;
    Paint;
    if Assigned(FOnChange) then
      FOnChange(Self);
  end;
end;

procedure TRangeSelector.SetState(State: TRangeSelectorState);
begin
  if State <> FState then
  begin
    FState := State;
    Paint;
  end;
end;

procedure TRangeSelector.SwapBuffers;
begin
  BitBlt(Canvas.Handle,
         0,
         0,
         Width,
         Height,
         FBuffer.Canvas.Handle,
         0,
         0,
         SRCCOPY);
end;

end.

Screenshot of the TRangeSelector control

还有一些事情需要改进，例如1）添加键盘界面，2）使标记显示可选并添加更多外观设置，4）捕捉到整数网格， 3）添加能够通过数字输入值尝试双击拇指！。

该控件可以在启用和不启用视觉主题的情况下工作，并且完全是双缓冲的。

答案 1 :(得分：7)

除了Andreas'不错的答案和组件外，还有另一个slider component能够：

  • 显示范围，
  • 显示该范围内的过滤范围
  • 拖动把手和绿色条，
  • 双击键盘输入夹点，
  • 通过键盘输入键盘，
  • 显示不同的数据类型，
  • 将值限制为步长。

Screenshot of demo form

（资料来源：NLDelphi.com）

答案 2 :(得分：0)

我不知道这样的事情，虽然可能有这样的事情。我会担心将一个标记移到另一个上面的可用性问题。当我在我的应用程序中询问范围时，我只是要求用户输入数字。

答案 3 :(得分：0)

TTrackBar有SelStart，SelEnd和ShowSelRange。然而它们似乎没什么用处 - 如果主题和AFAICT用户无法移动Sel *标记，它们几乎是不可见的。

答案 4 :(得分：0)

我建议进行一对旋转编辑。如果用户可以点击向上/向下，但大多数人只想输入他们的值：

alt text

相关问题
最新问题