加入收藏 | 设为首页 | 会员中心 | 我要投稿 李大同 （https://www.lidatong.com.cn/）- 科技、建站、经验、云计算、5G、大数据,站长网!
当前位置： 首页 > 大数据 > 正文

delphi – 用于输入一系列值的Component(类似于trackbar)

发布时间：2020-12-15 10:07:18 所属栏目：大数据 来源：网络整理
导读：我需要一个组件来输入范围.我正在思考带有两个标记的轨道栏.是否存在用于此目的的“原生Delphi”组件或可以轻松模拟它的组件？ 解决方法 我几分钟后写了这个： unit RangeSelector;interfaceuses SysUtils,Windows,Messages,Graphics,Classes,Controls,UxThe
我需要一个组件来输入范围.我正在思考带有两个标记的轨道栏.是否存在用于此目的的“原生Delphi”组件或可以轻松模拟它的组件？

解决方法

我几分钟后写了这个： 
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,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,FThumbPos2) then
    if Down then
      result := rssThumb2Down
    else
      result := rssThumb2Hover

  else if PointInRect(X,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,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,FMax) then
    begin
      SetSelStart(FSelStart + (X - FPrevX) * (FMax - FMin) / BarWidth);
      SetSelEnd(FSelEnd + (X - FPrevX) * (FMax - FMin) / BarWidth);
    end;
  end
  else
    SetState(DeduceState(X,FDown));

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

procedure TRangeSelector.MouseUp(Button: TMouseButton; Shift: TShiftState; X,Y: Integer);
begin
  inherited;
  FDown := false;
  SetState(DeduceState(X,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,TKP_THUMB,TUS_DISABLED,nil);
          rssBlockHover:
            DrawThemeBackground(theme,TUS_HOT,nil);
          rssBlockDown:
            DrawThemeBackground(theme,TUS_PRESSED,nil);
        else
          DrawThemeBackground(theme,TUS_NORMAL,nil);
        end;


        case FState of
          rssDisabled:
            DrawThemeBackground(theme,TKP_THUMBBOTTOM,TUBS_DISABLED,nil);
          rssThumb1Hover:
            DrawThemeBackground(theme,TUBS_HOT,nil);
          rssThumb1Down:
            DrawThemeBackground(theme,TUBS_PRESSED,TUBS_NORMAL,nil);
        end;

        case FState of
          rssDisabled:
            DrawThemeBackground(theme,TUTS_DISABLED,FThumbPos2,nil);
          rssThumb2Hover:
            DrawThemeBackground(theme,TUTS_HOT,nil);
          rssThumb2Down:
            DrawThemeBackground(theme,TUTS_PRESSED,nil);
        end;

      finally
        CloseThemeData(theme);
      end;

  end

  else

  begin

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

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

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

    case FState of
      rssDisabled:
        DrawEdge(FBuffer.Canvas.Handle,BF_RECT or BF_MONO);
      rssThumb1Hover:
        DrawEdge(FBuffer.Canvas.Handle,BF_RECT);
      rssThumb1Down:
        DrawEdge(FBuffer.Canvas.Handle,BF_RECT or BF_MONO);
      rssThumb2Hover:
        DrawEdge(FBuffer.Canvas.Handle,BF_RECT);
      rssThumb2Down:
        DrawEdge(FBuffer.Canvas.Handle,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,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,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,Width,Height,SRCCOPY);
end;

end.

Screenshot of TRangeSelector control http://privat.rejbrand.se/RangeSelector.png

还有一些需要改进的地方,例如：1)添加键盘界面,2)使标记的显示可选并添加更多外观设置,4)捕捉到整数网格,以及3)添加输入值的能力数字尝试双击拇指！

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

（编辑：李大同）

【声明】本站内容均来自网络，其相关言论仅代表作者个人观点，不代表本站立场。若无意侵犯到您的权利，请及时与联系站长删除相关内容!
    相关内容
      推荐文章
        站长推荐
        热点阅读

          【免责声明】本站内容转载自互联网，其发布内容言论不代表本站观点，如果其链接、内容的侵犯您的权益，烦请提交相关链接至邮箱bqsm@foxmail.com我们将及时予以处理。

          建议您使用1920×1080分辨率、谷歌浏览器Google Chrome、Microsoft Edge以获得本站的最佳浏览效果

          Copygight © 2008-2022 https://www.lidatong.com.cn/ All Rights Reserved. 李大同