Форум: "Основная";
Текущий архив: 2004.03.28;
Скачать: [xml.tar.bz2];

Вниз

TrackBar   Найти похожие ветки 

← →
TUser ©   (2004-03-05 09:25) [0]

Кто-нибудь может посоветовать компонент TTrackBar, но чтобы там можно было добавлять произвольное количество бегунков на одну дорожку. Конкретно меня интересует вариант с 2мя бегунками, но если будет больше - то хорошо.

---

← →
Никто   (2004-03-05 09:44) [1]

Вопрос не совсем понятен, поэтому могу лишь предложить использовать два TrackBar"а - один под другим. Если необходимо, чтобы один бегунок входил в зону другого - обрабатывать OnChange. Но не думаю, что это то, что Вам это нужно.

---

← →
TUser ©   (2004-03-05 10:00) [2]

Нет. Видели в Photoshop"е - там в Image->adj->Levels (Alt-L) и два и три бегунка есть на одной линии. Вот нужно что-то типа этого, а в остальном по оформлению сходной с TJvTrackBar.

---

← →
Семен Сорокин ©   (2004-03-05 10:06) [3]

реализовывал когда-то вертикальный, посмотри, может пригодится:

unit ChrtBrdr;

interface

uses
 SysUtils, Classes, Controls, Graphics, Windows, Messages;

type
 TSplValues = 1..1000;

 TSplDown = (sdNone, sdTop, sdBottom);

 TChartBorder = class;

 TSplUpDownEvent = procedure (Sender: TChartBorder; AIsTop: boolean; AYShift: integer; AValue: TSplValues) of object;

 TChartBorder = class(TGraphicControl)
 private
   FTopBorder: integer;
   FBottomBorder: integer;
   FSplTop: TSplValues;
   FSplBottom: TSplValues;
   FTopRgn: HRGN;
   FBottomRgn: HRGN;
   FButtonColor: TColor;
   FSplDown: TSplDown;
   FOnSplUp: TSplUpDownEvent;
   FOnSplDown: TSplUpDownEvent;
   FOnSplMove: TSplUpDownEvent;
   procedure FreeRegions;
   procedure SetSplBottom(const Value: TSplValues);
   procedure SetSplTop(const Value: TSplValues);
   procedure SetButtonColor(const Value: TColor);
   procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN;
   procedure WMLButtonUp(var Message: TWMLButtonUp); message WM_LBUTTONUP;
   procedure WMMouseMove(var Message: TWMMouseMove); message WM_MOUSEMOVE;
   function CalcPixelsBySpl(AValue: TSplValues): integer;
   procedure SetBottomBorder(const Value: integer);
   procedure SetTopBorder(const Value: integer);
   function GetSplHeight: integer;
 protected
   procedure DoSplMove; virtual;
   procedure DoSplDown; virtual;
   procedure DoSplUp; virtual;
   procedure Paint; override;
 public
   constructor Create(AOwner: TComponent); override;
   destructor Destroy; override;
   property SplHeight: integer read GetSplHeight;
   function SplTopInPixels: integer;
   function SplBottomInPixels: integer;
 published
   property SplTop: TSplValues read FSplTop write SetSplTop;
   property SplBottom: TSplValues read FSplBottom write SetSplBottom;
   property ButtonColor: TColor read FButtonColor write SetButtonColor;
   property TopBorder: integer read FTopBorder write SetTopBorder;
   property BottomBorder: integer read FBottomBorder write SetBottomBorder;
   property OnSplUp: TSplUpDownEvent read FOnSplUp write FOnSplUp;
   property OnSplDown: TSplUpDownEvent read FOnSplDown write FOnSplDown;
   property OnSplMove: TSplUpDownEvent read FOnSplMove write FOnSplMove;
   property ParentShowHint;
   property ShowHint;
   property Visible;
 end;

procedure Register;

implementation

procedure Register;
begin
RegisterComponents("Samples", [TChartBorder]);
end;

{Èíâåðòèðóåò öâåò}
function InvertColor(col: tColor): tColor;
begin
Result := RGB(255 - GetRValue(ColorToRGB(col)),
              255 - GetGValue(ColorToRGB(col)),
              255 - GetBValue(ColorToRGB(col)))
end;

{ --------------------------------- TChartBorder ----------------------------- }

function TChartBorder.CalcPixelsBySpl(AValue: TSplValues): integer;
begin
Result := FTopBorder+SplHeight-Round(SplHeight*AValue/1000);
end;

constructor TChartBorder.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
ControlStyle := [csClickEvents, csCaptureMouse];
Align := alLeft;
FSplTop := 1000;
FSplBottom := 1;
FButtonColor := clBlue;
FTopRgn := 0;
FBottomRgn := 0;
FTopBorder := 0;
FBottomBorder := 100;
FSplDown := sdNone
end;

destructor TChartBorder.Destroy;
begin
FreeRegions;
inherited Destroy
end;

procedure TChartBorder.DoSplDown;
begin
if Assigned(FOnSplDown) then
 if FSplDown = sdTop then
  FOnSplDown(self, true, SplTopInPixels, FSplTop)
 else
  FOnSplDown(self, false, SplBottomInPixels, FSplBottom)
end;

procedure TChartBorder.DoSplMove;
begin
if Assigned(FOnSplMove) then
 if FSplDown = sdTop then
  FOnSplMove(self, true, SplTopInPixels, FSplTop)
 else
  FOnSplMove(self, false, SplBottomInPixels, FSplBottom)
end;

procedure TChartBorder.DoSplUp;
begin
if Assigned(FOnSplUp) then
 if FSplDown = sdTop then
  FOnSplUp(self, true, SplTopInPixels, FSplTop)
 else
  FOnSplUp(self, false, SplBottomInPixels, FSplBottom)
end;



---

← →
Семен Сорокин ©   (2004-03-05 10:06) [4]

procedure TChartBorder.FreeRegions;
begin
if FTopRgn <> 0 then
 DeleteObject(FTopRgn);
if FBottomRgn <> 0 then
 DeleteObject(FBottomRgn);
FTopRgn := 0;
FBottomRgn := 0
end;

function TChartBorder.GetSplHeight: integer;
begin
Result := FBottomBorder - FTopBorder
end;

procedure TChartBorder.Paint;

function DrawTriangle(AY: integer): HRGN;
var
  _p: array [0..2] of TPoint;
begin
 _p[0] := Point(Width-1, AY);
 _p[1] := Point(Width-6, AY+4);
 _p[2] := Point(Width-6, AY-4);
 Result := CreatePolygonRgn(_p, 3, ALTERNATE);
 Canvas.Polygon(_p)
end;

begin
FreeRegions;
with Canvas do begin
 Pen.Color := clBlack;
 Pen.Style := psSolid;
 Brush.Style := bsClear;
 MoveTo(Width-7, 0);
 LineTo(Width-1, 0);
 LineTo(Width-1, Height-1);
 LineTo(Width-7, Height-1);
 Canvas.Brush.Style := bsSolid;
 if FSplDown = sdTop then
  Canvas.Brush.Color := InvertColor(FButtonColor)
 else
  Canvas.Brush.Color := FButtonColor;
 FTopRgn := DrawTriangle(CalcPixelsBySpl(FSplTop));
 if FSplDown = sdBottom then
  Canvas.Brush.Color := InvertColor(FButtonColor)
 else
  Canvas.Brush.Color := FButtonColor;
 FBottomRgn := DrawTriangle(CalcPixelsBySpl(FSplBottom))
end
end;

procedure TChartBorder.SetBottomBorder(const Value: integer);
begin
if (FBottomBorder <> Value) and (Value > FTopBorder) and (Value <= Height) then begin
 FBottomBorder := Value;
 Invalidate
end
end;

procedure TChartBorder.SetButtonColor(const Value: TColor);
begin
if FButtonColor <> Value then begin
 FButtonColor := Value;
 Invalidate
end
end;

procedure TChartBorder.SetSplBottom(const Value: TSplValues);
begin
if (FSplBottom <> Value) and (FSplTop > Value) then begin
 FSplBottom := Value;
 Invalidate
end
end;

procedure TChartBorder.SetSplTop(const Value: TSplValues);
begin
if (FSplTop <> Value) and (FSplBottom < Value) then begin
 FSplTop := Value;
 Invalidate
end
end;

procedure TChartBorder.SetTopBorder(const Value: integer);
begin
if (FTopBorder <> Value) and (Value >= 0) and (Value < FBottomBorder) then begin
 FTopBorder := Value;
 Invalidate
end
end;

function TChartBorder.SplBottomInPixels: integer;
begin
Result := CalcPixelsBySpl(FSplBottom)
end;

function TChartBorder.SplTopInPixels: integer;
begin
Result := CalcPixelsBySpl(FSplTop)
end;

procedure TChartBorder.WMLButtonDown(var Message: TWMLButtonDown);
begin
inherited;
if PtInRegion(FTopRgn, Message.XPos, Message.YPos) then
 FSplDown := sdTop
else if PtInRegion(FBottomRgn, Message.XPos, Message.YPos) then
 FSplDown := sdBottom
else
 FSplDown := sdNone;
if FSplDown <> sdNone then begin
 DoSplDown;
 Invalidate
end
end;

procedure TChartBorder.WMLButtonUp(var Message: TWMLButtonUp);
begin
inherited;
if FSplDown <> sdNone then
 DoSplUp;
FSplDown := sdNone;
Invalidate
end;

procedure TChartBorder.WMMouseMove(var Message: TWMMouseMove);
var
 _spl: integer;
begin
inherited;
if FSplDown <> sdNone then begin
 _spl := 1000-Round(1000*(Message.YPos-FTopBorder)/SplHeight);
 if _spl < 1 then
  _spl := 1
 else if _spl > 1000 then
  _spl := 1000;
 if FSplDown = sdTop then
  SplTop := _spl
 else
  SplBottom := _spl;
 DoSplMove
end
end;

end.

---

← →
TUser ©   (2004-03-05 12:18) [5]

Да. эТо примерно то, чтоя искал. Спасибо, дальше уже сам переделяю на нужный дизайн.

---

Страницы: 1 вся ветка

Форум: "Основная";
Текущий архив: 2004.03.28;
Скачать: [xml.tar.bz2];

Наверх

Память: 0.48 MB
Время: 0.1 c