解决方法
我几分钟后写了这个:
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.jb51.cc/delphi/103041.html
版权声明:本文内容由互联网用户自发贡献,该文观点与技术仅代表作者本人。本站仅提供信息存储空间服务,不拥有所有权,不承担相关法律责任。如发现本站有涉嫌侵权/违法违规的内容, 请发送邮件至 dio@foxmail.com 举报,一经查实,本站将立刻删除。