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

前端之家收集整理的这篇文章主要介绍了delphi – 用于输入一系列值的Component(类似于trackbar)前端之家小编觉得挺不错的,现在分享给大家,也给大家做个参考。
我需要一个组件来输入范围.我正在思考带有两个标记的轨道栏.是否存在用于此目的的“原生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)添加输入值的能力数字尝试双击拇指!

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

原文链接:https://www.f2er.com/delphi/103041.html

猜你在找的Delphi相关文章