我需要一个组件来输入范围.我正在思考带有两个标记的轨道栏.是否存在用于此目的的“原生Delphi”组件或可以轻松模拟它的组件？
解决方法
我几分钟后写了这个：
@H_502_6@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)添加输入值的能力数字尝试双击拇指！
该控件在启用和不启用可视主题的情况下都可以工作,并且完全是双缓冲的.