我需要一个组件来输入范围.我正在思考带有两个标记的轨道栏.是否存在用于此目的的“原生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)添加输入值的能力数字尝试双击拇指！
该控件在启用和不启用可视主题的情况下都可以工作,并且完全是双缓冲的.