Trackbar mit 2 Reglern gesucht

[Horst0815]

ich suche einen Trackbar mit 2 Reglern die sich aber völlig unabhängig voneinander über den gesamten Trackbar schieben lassen.

Hatte schon eine Komponente "Tracker" gefunden womit sich ein gewisser Bereich einstellen lässt.

Delphi-Quellcode:

unit Tracker2;

{*******************************************************************************
 *  This trackbar component is an extension of tDCTrack by Doug Gregor         *
 * ([e-mail]).  My modifications allow the use of trackbars with either  *
 *  one or two thumb buttons, the latter being useful in defining "windowed"   *
 *  controls.                                                                  *
 *                                                                             *
 *  All of the hard effort and 95% of the code here is the work of Mr. Gregor, *
 *  and he has my thanks for making it widely available.  I've made a few      *
 *  changes to reflect my preferences and style                                *
 *                                                                             *
 *      When SecondThumb is property is true, two thumb buttons appear on the  *
 *      trackbar, along with a "midpoint marker" that is always present between*
 *      the two thumb buttons.  Mouse clicks on the trackbar operate on the    *
 *      upper or lower button depending on which side of the marker the mouse  *
 *      pointer is on.  The buttons may never cross the midpoint marker, so the*
 *      "upper" button is always above the lower one on a vertical track.      *
 *                                                                             *
 *      Click and drag on either button to move it.                            *
 *      Click to one side of button to move it to mouse position.              *
 *      Shift+Click to one side to move the button a small increment toward    *
 *         the mouse.                                                          *
 *                                                                             *
 *      Shift+arrow key moves the upper button and arrow keys alone move       *
 *      the lower button if SecondThumb is true.  (Shift is ignored in one-    *
 *      button trackbars).  Use pageup and pagedown to move in larger steps.   *
 *                                                                             *
 *                                                                             *
 *  This component has been tested with Delphi3 under Win2000 and WinXP.       *
 *                                                                             *
 *                                                                             *
 *                                      Curt Carpenter                         *
 *                                      Dallas, Tx  July 5, 2010               *
 *                                                                             *
 *  Notes:                                                                     *
 *      o  ThumbColor property only works with rectangular thumb style         *
 *      o  Don't forget to change the registration procedure before installing *
 *         to reflect your prefered IDE layout.                                *
 *******************************************************************************
}

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  Dialogs, Menus;

type
  TOrientation=(toHorizontal,toVertical);
  TTrackStyle=(trUserDrawn,trFlat,trRaised,trLowered);
  TThumbStyle=(tsUserDrawn,tsRectangle,tsRaisedRectangle,tsLoweredRectangle,
               tsSmallPointer,tsMediumPointer,tsLargePointer);
  TTickStyle=(tiUserDrawn,tiLine,tiSquare,tiRaisedSquare,tiLoweredSquare);
  TTickOrientation=(toTopLeft,toBottomRight,toBoth);
  TDrawTrackEvent=procedure(Sender:TObject;Canvas:TCanvas) of object;
  TDrawThumbEvent=procedure(Sender:TObject;Canvas:TCanvas;X,Y:Integer)
                            of object;
  TDrawTickEvent=procedure(Sender:TObject;Canvas:TCanvas;X,Y,Position:Integer)
                           of object;

  TTrackBar2 = class(TCustomControl)
  private
    {track}
    FMax,
    FMin: integer;
    FTrackRect:TRect;
    FUsablePixels:Integer;
    FOrientation:TOrientation;
    FTrackSize:Integer;
    FTrackStyle:TTrackStyle;
    FTrackColor:TColor;
    {ticks}
    FTickSize:Integer;
    FTickStyle:TTickStyle;
    FTickColor:TColor;
    FTickOrientation:TTickOrientation;
    FTickInterval:Integer;
    {thumbs}
    FDitherThumb:Boolean;
    FSmallChange,
    FLargeChange:Integer;
    FThumbSize:Integer;
    FThumbStyle:TThumbStyle;
    FThumbColor:TColor;
    FSecondThumb: Boolean; //true if trackbar has two thumb buttons.
    FCentering:Integer;
    FThumbHalfSize:Integer;
    {midpoint market present when secondthumb = true}
    FXM,                   //midpoint marker restore coordinate
    FYM: integer;          //midpoint marker restore coordinate
    {lower or leftmost thumb.  Only thumb if secondthumb=false}
    FPositionL,
    FXL,                   //restore coordinate
    FYL: integer;          //restore coordinate
    FTrackingL: boolean;   //drag flag
    FThumbRectL:TRect;
    {upper or rightmost thumb.  Present if secondthumb = true}
    FPositionU,
    FXU,                   //restore coordinate
    FYU:Integer;           //restore coordinate
    FTrackingU:Boolean;    //drag flag
    FThumbREctU:TRect;
    {events}
    FOnChange,
    FOnPaint:TNotifyEvent;
    FOnDrawTrack:TDrawTrackEvent;
    FOnDrawThumb:TDrawThumbEvent;
    FOnDrawTick:TDrawTickEvent;
    {bitmaps}
    FThumbBmp,
    FBackgroundBmpM,        //midpoint tick background store
    FBackgroundBmpU,        //upper thumb background store
    FBackgroundBmpL,        //lower thumb background store
    FMaskBmp,
    FTickBmp,
    FDitherBmp:TBitmap;

    {Track}
    procedure SetMax(Value:Integer);
    procedure SetMin(Value:Integer);
    procedure SetOrientation(Value:TOrientation);
    procedure SetTrackSize(Value:Integer);
    procedure SetTrackStyle(Value:TTrackStyle);
    procedure SetTrackColor(Value:TColor);
    {Ticks}
    procedure SetTickSize(Value:Integer);
    procedure SetTickStyle(Value:TTickStyle);
    procedure SetTickColor(Value:TColor);
    procedure SetTickOrientation(Value:TTickOrientation);
    procedure SetTickInterval(Value:Integer);
    {Thumbs}
    procedure SetPositionL(Value:Integer);
    procedure SetPositionU(Value:Integer);
    procedure SetThumbSize(Value:Integer);
    procedure SetThumbStyle(Value:TThumbStyle);
    procedure SetThumbColor(Value:TColor);
    procedure SetDitherThumb(Value:Boolean);
    procedure SetSecondThumb(Value:Boolean);

    procedure WMGetDlgCode(var Msg:TWMGetDlgCode);message WM_GetDlgCode;
    procedure WMSize(var Msg:TWMSize);message WM_Size;
    procedure CMEnabledChanged(var Msg:TMessage); message CM_EnabledChanged;
    procedure CMCtl3DChanged(var Msg:TMessagE); message CM_Ctl3DChanged;

  protected
    {Track}
    procedure UpdateTrackData;virtual;
    procedure UpdateTrack;virtual;
    procedure DrawTrack;virtual;
    {Ticks}
    procedure UpdateTickData;virtual;
    procedure UpdateTicks;virtual;
    procedure DrawTick(X,Y,Position:Integer);virtual;
    {Thumbs}
    procedure UpdateThumbData;virtual;
    procedure UpdateThumb;virtual;
    procedure DrawThumb(X,Y:Integer);virtual;
    procedure UpdateDitherBitmap;virtual;
    procedure KeyDown(var Key:Word;Shift:TShiftState);override;
    procedure MouseDown(Button:TMouseButton;Shift:TShiftState;X,Y:Integer);
                        override;
    procedure MouseMove(Shift:TShiftState;X,Y:Integer);override;
    procedure MouseUp(Button:TMouseButton;Shift:TShiftState;X,Y:Integer);
                      override;

    procedure DoEnter;override;
    procedure DoExit;override;
    procedure Paint;override;
    procedure Change;virtual;

  public
    { Public declarations }
    constructor Create(AOwner:TComponent);override;
    destructor Destroy;override;
  published
    {   Track   }
    property Max:Integer read FMax write SetMax default 10;
    property Min:Integer read FMin write SetMin default 0;
    property Orientation:TOrientation read FOrientation
                                      write SetOrientation
                                      default toHorizontal;
    property TrackSize:Integer read FTrackSize write SetTrackSize default 10;
    property TrackStyle:TTrackStyle read FTrackStyle
                                    write SetTrackStyle
                                    default trLowered;
    property TrackColor:TColor read FTrackColor
                               write SetTrackColor
                               default clWhite;

    {   Ticks  }
    property TickSize:Integer read FTickSize write SetTickSize default 6;
    property TickStyle:TTickStyle read FTickStyle
                                  write SetTickStyle
                                  default tiRaisedSquare;
    property TickColor:TColor read FTickColor
                              write SetTickColor
                              default clBtnFace;
    property TickOrientation:TTickOrientation read FTickOrientation
                                              write SetTickOrientation
                                              default toBoth;
    property TickInterval:Integer read FTickInterval
                                  write SetTickInterval
                                  default 1;

    {   Thumb buttons   }
    property PositionL:Integer read FPositionL write SetPositionL default 0;
    property PositionU:Integer read FPositionU write SetPositionU default 10;
    property SmallChange:Integer read FSmallChange write FSmallChange default 1;
    property LargeChange:Integer read FLargeChange write FLargeChange default 2;
    property ThumbSize:Integer read FThumbSize write SetThumbSize default 20;
    property ThumbStyle:TThumbStyle read FThumbStyle
                                    write SetThumbStyle
                                    default tsRaisedRectangle;
    property ThumbColor:TColor      read FThumbColor
                                    write SetThumbColor
                                    default clBtnFace;
    property SecondThumb:Boolean    read FSecondThumb
                                    write SetSecondThumb
                                    Default False;
    property DitherThumb:Boolean    read FDitherThumb
                                    write SetDitherThumb
                                    default True;
    property TrackingU:Boolean      read FTrackingU;
    property TrackingL:Boolean      read FTrackingL;

    property Align;
    property Left;
    property Top;
    property Width;
    property Height;
    property Visible;
    property Enabled;
    property Font;
    property ParentFont;
    property ParentColor;
    property ParentShowHint;
    property PopupMenu;
    property TabOrder;
    property TabStop default True;
    property ShowHint;
    property Hint;
    property Cursor;
    property Ctl3D;
    property DragCursor;
    property DragMode;
    property HelpContext;
    property OnChange:TNotifyEvent read FOnChange write FOnChange;
    property OnPaint:TNotifyEvent read FOnPaint write FOnPaint;
    property OnDrawTrack:TDrawTrackEvent read FOnDrawTrack write FOnDrawTrack;
    property OnDrawThumb:TDrawThumbEvent read FOnDrawThumb write FOnDrawThumb;
    property OnDrawTick:TDrawTickEvent read FOnDrawTick write FOnDrawTick;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnEnter;
    property OnExit;
    property OnKeyDown;
    property OnKeyUp;
    property OnKeyPress;
    property OnClick;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnStartDrag;
    property OnEndDrag;
  end;

procedure Register;

implementation

{$R TRACKER2.RES}

procedure TTrackBar2.WMGetDlgCode(var Msg:TWMGetDlgCode);
begin
  inherited;
  {We want to receive arrow key codes}
  Msg.Result := dlgc_WantArrows;
end;

procedure TTrackBar2.CMEnabledChanged(var Msg:TMessage);
begin
  inherited;
  Invalidate;
end;

procedure TTrackBar2.CMCtl3DChanged(var Msg:TMessagE);
begin
  inherited;
  if Ctl3D then
  begin
    TrackStyle := trLowered;
    if FThumbStyle in [tsRectangle,tsLoweredRectangle]
      then ThumbStyle := tsRaisedRectangle;
  end;
end;

procedure TTrackBar2.WMSize(var Msg:TWMSize);
begin
  inherited;
  if Width>Height then FOrientation := toHorizontal
  else if Height>Width then FOrientation := toVertical;
  UpdateThumbData;
  UpdateTrackData;
end;

{============================================================================
                                   Thumbs
   Set property SecondThumb to True for two thumb buttons, or False for one.
   Buttons share the same size, color and style.
 ============================================================================}
procedure TTrackBar2.SetThumbSize(Value:Integer);
begin
 if Value<>FThumbSize then
  begin
    FThumbSize := Value;
    UpdateThumbData;
    UpdateTrackData;
    Invalidate;
  end;
end;

procedure TTrackBar2.SetThumbStyle(Value:TThumbStyle);
begin
 if Value<>FThumbStyle then
  begin
    FThumbStyle := Value;
    UpdateThumbData;
    UpdateTrackData;
    Invalidate;
  end;
end;

procedure TTrackBar2.SetThumbColor(Value:TColor);
begin
 if Value<>FThumbColor then
  begin
    FThumbColor := Value;
    UpdateThumbData;
    Invalidate;
  end;
end;

procedure TTrackBar2.SetSecondThumb(Value:Boolean);
begin
 if Value<>FSecondThumb then
  begin
    FSecondThumb := Value;
    UpdateThumbData;
    Invalidate;
  end;
end;

procedure TTrackBar2.SetDitherThumb(Value:Boolean);
begin
 if Value<>FDitherThumb then
  begin
    FDitherThumb := Value;
    if not Enabled then Invalidate;
  end;
end;

procedure TTrackBar2.UpdateDitherBitmap;
{This dithering routine take from Ray Konopka's "Developing Custom Delphi
 Components" p263-4}
var
  C:TColor;
  I,J:Integer;
begin
  if ColorToRGB(FTrackColor)=clSilver then C := clGray else C := clSilver;
  with FDitherBmp.Canvas do
  begin
    Brush.Color := FTrackColor;
    FillRect(Rect(0,0,FDitherBmp.Width,FDitherBmp.Height));
    for I := 0 to 7 do
      for J := 0 to 7 do if ((I+J) mod 2)<>0 then Pixels[I,J] := C;
  end;
end;


procedure TTrackBar2.SetPositionL(Value:Integer);
begin
 if (Value<>FPositionL) then
  begin
    FPositionL := Value;
      {The left thumb cannot be over or to the right of the right thumb.}
    if (FSecondThumb) and (FPositionL >= FPositionU) then FPositionL := FPositionU-1
    else
      {In case there is no right thumb}
    if (FPositionL > FMax) then FPositionL := FMax
    else
    if (FPositionL < FMin) then FPositionL := FMin;
    Change;
    if csDesigning in ComponentState then Invalidate
    else UpdateThumb;
  end;
end;


procedure TTrackBar2.SetPositionU(Value:Integer);
begin
  if (Value<>FPositionU) then
  begin
    FPositionU := Value;
    if (FPositionU > FMax) then FPositionU := FMax
    else
    if (FPositionU <= FPositionL) then FPositionU := FPositionL+1;
    Change;
    if csDesigning in ComponentState then Invalidate
    else UpdateThumb;
  end;
end;

procedure TTrackBar2.KeyDown(var Key:Word;Shift:TShiftState);
var TargetPosition: Integer;
    MOveU: Boolean;
begin
 if (ssShift in Shift) and (FSecondThumb) then
  begin TargetPosition := FPositionU; MoveU := True end
 else
  begin TargetPosition := FPositionL; MoveU := False end;
 case Key of
   VK_LEFT,VK_DOWN: TargetPosition := TargetPosition-FSmallChange;
   VK_RIGHT,VK_UP:  TargetPosition := TargetPosition+FSmallChange;
   VK_PRIOR:        TargetPosition := TargetPosition+FLargeChange;
   VK_NEXT:         TargetPosition := TargetPosition-FLargeChange
 end; {case}
 if MoveU then PositionU := TargetPosition
 else PositionL := TargetPosition;
 inherited KeyDown(Key,Shift);
end;

procedure TTrackBar2.MouseDown(Button:TMouseButton;Shift:TShiftState;X,
                                Y:Integer);
var MidPt: integer;
begin
 inherited MouseDown(Button,Shift,X,Y);
 SetFocus;
 if Button=mbLeft then
  begin

   if (FOrientation=toHorizontal) then
   {****************************************}
   {****    Horizontal Trackbar Case    ****}
   {****************************************}
    begin
     MidPt := (FThumbRectL.Right + FThumbREctU.Left) div 2;
     if (FSecondThumb) and (X > MidPt) then
      begin {handle right thumb}
       if PtInRect(FThumbRectU,Point(X,Y)) then FTrackingU := True
       else
       if (ssShift in Shift) then
        begin
         if X>FThumbRectU.Right  then PositionU := FPositionU+SmallChange
         else
         if (X<FThumbRectU.Left) then PositionU := FPositionU-SmallChange;
        end
       else {not ssShift in Shift}
        begin
         X := X-FThumbHalfSize;
         PositionU := X*(FMax-FMin) div FUsablePixels;
        end;
      end
     else {no second thumb or X <= MidPt:  handle left thumb}
      begin
       if PtInRect(FThumbRectL,Point(X,Y)) then FTrackingL := True
       else
       if (ssShift in Shift) then
        begin
         if X>FThumbRectL.Right  then PositionL := FPositionL+SmallChange
         else
         if (X<FThumbRectL.Left) then PositionL := FPositionL-SmallChange;
        end
       else {not ssShift in Shift}
        begin
         X := X-FThumbHalfSize;
         PositionL := X*(FMax-FMin) div FUsablePixels;
        end;
     end;
    end   {Horizontal trackbar case}

   else
    {****************************************}
    {****     Vertical Trackbar Case     ****}
    {****************************************}
    begin
     MidPt := (FThumbRectL.Top + FThumbREctU.Bottom) div 2;
     if (FSecondThumb) and (Y < MidPt) then
      begin {handle upper thumb}
       if PtInRect(FThumbRectU,Point(X,Y)) then FTrackingU := True
       else
       if (ssShift in Shift) then
        begin
         if Y<FThumbRectU.Top  then PositionU := FPositionU+SmallChange
         else
         if (Y>FThumbRectU.Bottom) then PositionU := FPositionU-SmallChange;
        end
       else {not ssShift in Shift}
        begin
         Y := Y+FThumbHalfSize;
         PositionU := (FMax-Y*(FMax-FMin) div FUsablePixels);
        end
      end
     else {no second thumb or Y >= midPt:  handle lower thumb}
      begin
       if PtInRect(FThumbRectL,Point(X,Y)) then FTrackingL := True
       else
       if (ssShift in Shift) then
        begin
         if Y>FThumbRectL.Bottom  then PositionL := FPositionL-SmallChange
         else
         if (Y<FThumbRectL.Top) then PositionL := FPositionL+SmallChange;
        end
       else {not ssShift in Shift}
        begin
         Y := Y+FThumbHalfSize;
        PositionL := (FMax-Y*(FMax-FMin) div FUsablePixels);
        end
     end;
    end;
  end;
end;         

procedure TTrackBar2.MouseMove(Shift:TShiftState;X,Y:Integer);
begin
  inherited MouseMove(Shift,X,Y);
  if FTrackingU then
   begin
    if FOrientation=toHorizontal then
     begin
       X := X-FThumbHalfSize;
       PositionU := X*(FMax-FMin) div FUsablePixels;
     end
    else
     begin
       Y := Y+FThumbHalfSize;
       PositionU := (FMax-Y*(FMax-FMin) div FUsablePixels);
     end;
   end
  else
  if FTrackingL then
   begin
     if FOrientation=toHorizontal then
      begin
        X := X-FThumbHalfSize;
        PositionL := X*(FMax-FMin) div FUsablePixels;
      end
     else
      begin
        Y := Y+FThumbHalfSize;
        PositionL := (FMax-Y*(FMax-FMin) div FUsablePixels);
      end;
   end;
end;

procedure TTrackBar2.MouseUp(Button:TMouseButton;Shift:TShiftState;X,Y:Integer);
begin
  if Button=mbLeft then
   begin FTrackingU := False; FTrackingL := False end;
end;

procedure TTrackBar2.UpdateThumbData;
var
  ResStr:String[17];
begin
  if FThumbStyle in [tsRectangle,tsRaisedRectangle,tsLoweredRectangle] then
   begin
     FThumbHalfSize := FThumbSize div 4;
     if FOrientation=toHorizontal then
      begin
        FThumbBmp.Width := FThumbSize div 2;
        FThumbBmp.Height := FThumbSize;
      end
     else
      begin
        FThumbBmp.Width := FThumbSize;
        FThumbBmp.Height := FThumbSize div 2;
      end;
     with FThumbBmp do
      begin
       Canvas.Brush.Color := ThumbColor;
       Canvas.Brush.Style := bsSolid;
       Canvas.FillRect(Rect(0,0,Width,Height));
       if FThumbStyle=tsRectangle then
        begin
         Canvas.Pen.Color := clBlack;
         Canvas.Rectangle(0,0,Width,Height);
        end
       else
        begin
         if FThumbStyle=tsRaisedRectangle then Canvas.Pen.Color := clWhite
         else Canvas.Pen.Color := clBlack;
         Canvas.MoveTo(0,Height-1);
         Canvas.LineTo(0,0);
         Canvas.LineTo(Width-1,0);
         if FThumbStyle=tsRaisedRectangle then Canvas.Pen.Color := clBlack
         else Canvas.Pen.Color := clWhite;
         Canvas.LineTo(Width-1,Height-1);
         Canvas.LineTo(0,Height-1);
         if FThumbStyle=tsRaisedRectangle then Canvas.Pen.Color := clSilver
         else Canvas.Pen.Color := clGray;
         Canvas.MoveTo(1,Height-2);
         Canvas.LineTo(1,1);
         Canvas.LineTo(Width-2,1);
         if FThumbStyle=tsRaisedRectangle then Canvas.Pen.Color := clGray
         else Canvas.Pen.Color := clSilver;
         Canvas.LineTo(Width-2,Height-2);
         Canvas.LineTo(1,Height-2);
        end;
      end;
   end
  else
  if FThumbStyle=tsSmallPointer then
   begin
     if FOrientation=toHorizontal then
      begin
       case FTickOrientation of
         toTopLeft,toBoth:ResStr := 'SMUPTHUMB';
         toBottomRight:ResStr := 'SMDOWNTHUMB';
       end;
      end
     else
      case FTickOrientation of
       toTopLeft,toBoth:ResStr := 'SMLEFTTHUMB';
       toBottomRight:ResStr := 'SMRIGHTTHUMB';
      end;
     FThumbBmp.LoadFromResourceName(HInstance,ResStr);
     if FOrientation=toHorizontal then FThumbSize := FThumbBmp.Width
     else FThumbSize := FThumbBmp.Height;
     FThumbHalfSize := FThumbSize div 2;
     ResStr := ResStr+'MASK';
     FMaskBmp.LoadFromResourceName(HInstance,ResStr);
   end
  else
  if FThumbStyle=tsMediumPointer then
   begin
     if FOrientation=toHorizontal then
      begin
       case FTickOrientation of
         toTopLeft,toBoth:ResStr := 'MEDUPTHUMB';
         toBottomRight:ResStr := 'MEDDOWNTHUMB';
       end;
      end
     else
      case FTickOrientation of
       toTopLeft,toBoth:ResStr := 'MEDLEFTTHUMB';
       toBottomRight:ResStr := 'MEDRIGHTTHUMB';
      end;
     FThumbBmp.LoadFromResourceName(HInstance,ResStr);
     if FOrientation=toHorizontal then FThumbSize := FThumbBmp.Width
     else FThumbSize := FThumbBmp.Height;
     FThumbHalfSize := FThumbSize div 2;
     ResStr := ResStr+'MASK';
     FMaskBmp.LoadFromResourceName(HInstance,ResStr);
   end
  else
  if FThumbStyle=tsLargePointer then
   begin
     if FOrientation=toHorizontal then
      begin
       case FTickOrientation of
         toTopLeft,toBoth:ResStr := 'LGUPTHUMB';
         toBottomRight:ResStr := 'LGDOWNTHUMB';
       end;
      end
     else
      case FTickOrientation of
       toTopLeft,toBoth:ResStr := 'LGLEFTTHUMB';
       toBottomRight:ResStr := 'LGRIGHTTHUMB';
      end;
     FThumbBmp.LoadFromResourceName(HInstance,ResStr);
     if FOrientation=toHorizontal then FThumbSize := FThumbBmp.Width
     else FThumbSize := FThumbBmp.Height;
     FThumbHalfSize := FThumbSize div 2;
     ResStr := ResStr+'MASK';
     FMaskBmp.LoadFromResourceName(HInstance,ResStr);
   end
  else
   begin
     FThumbBmp.Width := FThumbSize;
     FThumbBmp.Height := FThumbSize;
     FThumbHalfSize := FThumbSize div 2;
   end;
  FBackgroundBmpL.Width := FThumbBmp.Width;
  FBackgroundBmpL.Height := FThumbBmp.Height;
  FBackgroundBmpU.Width := FThumbBmp.Width;
  FBackgroundBmpU.Height := FThumbBmp.Height;
end;

procedure TTrackBar2.UpdateThumb;
var
  XL,YL,XU,YU,TempX,TempY,MidPt:Integer;
  WorkBmp:TBitmap;
  TempRect:TRect;
begin
  {******** Erase existing thumbs and midpoint tick ********}
  if (FXL<>MaxInt) and (FYL<>MaxInt) then
    Canvas.Draw(FXL,FYL,FBackgroundBmpL);
  if (SecondThumb) then {Two-thumb trackbar}
   begin  {erase the upper thumb and tick}
    if (FXU<>MaxInt) and (FYU<>MaxInt) then
     begin
        Canvas.Draw(FXU,FYU,FBackgroundBmpU);
        {erase the mid-point tick}
        Canvas.Draw(FXM,FYM,FBackgroundBmpM);
     end;
   end;

  {******** Update restoration locations ********}
  if FOrientation=toHorizontal then
   begin  {horizontal case}
    XL := (FUsablePixels*FPositionL) div (FMax-FMin)+FCentering;
    YL := (Height div 2)-(FThumbBmp.Height div 2);
    if (SecondThumb) then
     begin
      YU := YL;
      XU := (FUsablePixels*FPositionU) div (FMax-FMin)+FCentering;
      FXU := XU;
      FYU := YU;
      FXM := ((XU+XL+FThumbBmp.Width) div 2)-1;
      FYM := FTrackRect.Top;
     end;
   end
  else
   begin  {vertical case}
    XL := (Width div 2)-(FThumbBmp.Width div 2);
    YL := (FUsablePixels*(FMax-FPositionL)) div (FMax-FMin)+FCentering;
    if (SecondThumb) then
     begin
      XU := XL;
      YU := (FUsablePixels*(FMax-FPositionU)) div (FMax-FMin)+FCentering;
      FXU := XU;
      FYU := YU;
      FXM := FTrackRect.Left;
      FYM := (YL + YU + FThumbBmp.Height) div 2 - 1;
     end;
   end;
  FXL := XL;
  FYL := YL;

  {********  Save the areas under the new thumb positions  ********}
  FBackgroundBmpL.Canvas.CopyRect(Rect(0,0,FBackgroundBmpL.Width,
                                 FBackgroundBmpL.Height),Canvas,Rect(XL,YL,
                                 XL+FBackgroundBmpL.Width,
                                 YL+FBackgroundBmpL.Height));
  if (FSecondThumb) then
   begin
    FBackgroundBmpU.Canvas.CopyRect(Rect(0,0,FBackgroundBmpU.Width,
                                 FBackgroundBmpU.Height),Canvas,Rect(XU,YU,
                                 XU+FBackgroundBmpU.Width,
                                 YU+FBackgroundBmpU.Height));
    FBackgroundBmpM.Canvas.CopyRect(Rect(0,0,FBackgroundBmpM.Width,
                                 FBackgroundBmpM.Height),Canvas,Rect(FXM,FYM,
                                 FXM+FBackgroundBmpM.Width,
                                 FYM+FBackgroundBmpM.Height));
   end;

  {******** Now draw the thumbs in their new position ********}
  if FThumbStyle=tsUserDrawn then
   begin
    DrawThumb(XL,YL);
    if (FSecondThumb) then DrawThumb(XU,YU);
    Exit;
   end;
  WorkBmp := TBitmap.Create;
  try
    WorkBmp.Width := FThumbBmp.Width;
    WorkBmp.Height := FThumbBmp.Height;
    if FThumbStyle in [tsSmallPointer,tsMediumPointer,tsLargePointer] then
     begin
      {This masking routine take from Ray Konopka's "Developing Custom Delphi
       Components" p266-7}
      TempRect := Rect(0,0,FThumbBmp.Width,FThumbBmp.Height);
      WorkBmp.Canvas.CopyMode := cmSrcCopy;
      WorkBmp.Canvas.CopyRect(TempRect,FBackgroundBmpL.Canvas,TempRect);
      WorkBmp.Canvas.CopyMode := cmSrcAnd;
      WorkBmp.Canvas.CopyRect(TempRect,FMaskBmp.Canvas,TempRect);
      WorkBmp.Canvas.CopyMode := cmSrcPaint;
      WorkBmp.Canvas.CopyRect(TempRect,FThumbBmp.Canvas,TempRect);
     end
    else WorkBmp.Canvas.Draw(0,0,FThumbBmp);
    if (not Enabled) and (FDitherThumb) then
     begin
      WorkBmp.Canvas.Brush.Bitmap := FDitherBmp;
      TempX := WorkBmp.Width div 2;
      TempY := WorkBmp.Height div 2;
      WorkBmp.Canvas.FloodFill(TempX,TempY,WorkBmp.Canvas.Pixels[TempX,TempY],
                               fsSurface);
     end;
    Canvas.Draw(XL,YL,WorkBmp);
    if (FSecondThumb) then
     begin {Draw upper thumb and the midpoint tick}
      Canvas.Draw(XU,YU,WorkBmp);
     if FOrientation=toHorizontal then
       begin
        MidPt := (XU+XL+FThumbBmp.Width) div 2;
        Canvas.Pen.Color := clBlack;
        Canvas.MoveTo(MidPt, FTrackRect.Bottom);
        Canvas.LineTo(MidPt, FTrackRect.Top);
       end
     else
       begin
        MidPt := (YU+YL+FThumbBmp.Height) div 2;
        Canvas.Pen.Color := clBlack;
        Canvas.MoveTo(FTrackRect.Left,MidPt);
        Canvas.LineTo(FTrackRect.Right,MidPt);
       end
     end;

  finally
    WorkBmp.Free;
  end;
  FThumbRectL.Left := XL;
  FThumbRectL.Top := YL;
  FThumbRectL.Right := XL+FThumbBmp.Width;
  FThumbRectL.Bottom := YL+FThumbBmp.Height;
  FThumbRectU.Left := XU;
  FThumbRectU.Top := YU;
  FThumbRectU.Right := XU+FThumbBmp.Width;
  FThumbRectU.Bottom := YU+FThumbBmp.Height;
end;


{============================================================================
                                   Track
 ============================================================================}
procedure TTrackBar2.SetMax(Value:Integer);
begin
 if Value<>FMax then
  begin
    FMax := Value;
    if FPositionU>FMax then FPositionU := FMax;
    Invalidate;
  end;
end;

procedure TTrackBar2.SetMin(Value:Integer);
begin
 if Value<>FMin then
  begin
    FMin := Value;
    if FPositionL<FMin then FPositionL := FMin;
    Invalidate;
  end;
end;

procedure TTrackBar2.SetOrientation(Value:TOrientation);
var temp: integer;
begin
 if Value<>FOrientation then
  begin
    FOrientation := Value;
    if (((FOrientation = toVertical) and (width > height)) or
       ((FOrientation = toHorizontal) and (height > width )))
    then
      begin temp := width; width := height; height := temp end;
    UpdateThumbData;
    UpdateTrackData;
    Invalidate;
  end;
end;

procedure TTrackBar2.SetTrackSize(Value:Integer);
begin
 if Value<>FTrackSize then
  begin
    FTrackSize := Value;
    UpdateTrackData;
    Invalidate;
  end;
end;

procedure TTrackBar2.SetTrackStyle(Value:TTrackStyle);
begin
 if Value<>FTrackStyle then
  begin
    FTrackStyle := Value;
    Invalidate;
  end;
end;

procedure TTrackBar2.SetTrackColor(Value:TColor);
begin
 if Value<>FTrackColor then
  begin
    FTrackColor := Value;
    Invalidate;
  end;
end;

procedure TTrackBar2.UpdateTrackData;
begin
 if FOrientation=toHorizontal then
   begin
     FUsablePixels := Width-FThumbSize;
     FTrackRect.Left := (FUsablePixels*FMin) div (FMax-FMin)+FThumbHalfSize;
     FTrackRect.Right := (FUsablePixels*FMax) div (FMax-FMin)+FThumbHalfSize;
     FCentering := (Width-(FTrackRect.Right-FTrackRect.Left)) div 2;
     FCentering := FCentering-FThumbHalfSize;
     FTrackRect.Left := FTrackRect.Left+FCentering;
     FTrackRect.Right := FTrackRect.Right+FCentering;
     FTrackRect.Top := (Height div 2)-(FTrackSize div 2);
     FTrackRect.Bottom := (Height div 2)+(FTrackSize div 2);
     FBackgroundBmpM.Width := 2;
     FBackgroundBmpM.Height := FTrackRect.Bottom - FTrackRect.Top + 1;
   end
 else
   begin
     FUsablePixels := Height-FThumbSize;
     FTrackRect.Left := (Width div 2)-(FTrackSize div 2);
     FTrackRect.Right := (Width div 2)+(FTrackSize div 2);
     FTrackRect.Top := (FUsablePixels*FMin) div (FMax-FMin)+FThumbHalfSize;
     FTrackRect.Bottom := (FUsablePixels*FMax) div (FMax-FMin)+FThumbHalfSize;
     FCentering := (Height-(FTrackRect.Bottom-FTrackRect.Top)) div 2;
     FCentering := FCentering-FThumbHalfSize;
     FTrackRect.Top := FTrackRect.Top+FCentering;
     FTrackRect.Bottom := FTrackRect.Bottom+FCentering;
     FBackgroundBmpM.Width := FTrackRect.Right - FTrackRect.Left;
     FBackgroundBmpM.Height := 3;
   end;
end;

procedure TTrackBar2.UpdateTrack;
begin
 if FTrackStyle=trUserDrawn then DrawTrack
 else
  begin
    Canvas.Pen.Color := clBlack;
    if Enabled then
     begin
      Canvas.Brush.Style := bsSolid;
      Canvas.Brush.Color := FTrackColor;
     end
    else Canvas.Brush.Bitmap := FDitherBmp;
    Canvas.FillRect(FTrackRect);
    if FTrackStyle in [trRaised,trLowered] then with FTrackRect do
     begin
      if FTrackStyle=trRaised then Canvas.Pen.Color := clWhite
      else Canvas.Pen.Color := clBlack;
      Canvas.MoveTo(Left,Bottom);
      Canvas.LineTo(Left,Top);
      Canvas.LineTo(Right,Top);
      if FTrackStyle=trRaised then Canvas.Pen.Color := clBlack
      else Canvas.Pen.Color := clWhite;
      Canvas.LineTo(Right,Bottom);
      Canvas.LineTo(Left,Bottom);
      if FTrackStyle=trRaised then Canvas.Pen.Color := clSilver
      else Canvas.Pen.Color := clGray;
      Canvas.MoveTo(Left+1,Bottom-1);
      Canvas.LineTo(Left+1,Top+1);
      Canvas.LineTo(Right-1,Top+1);
      if FTrackStyle=trRaised then Canvas.Pen.Color := clGray
      else Canvas.Pen.Color := clSilver;
      Canvas.LineTo(Right-1,Bottom-1);
      Canvas.LineTo(Left+1,Bottom-1);
     end;
  end;
end;

{============================================================================
                                   Ticks
 ============================================================================}
procedure TTrackBar2.SetTickSize(Value:Integer);
begin
 if FTickSize<>Value then
  begin
   FTickSize := Value;
   UpdateTickData;
   Invalidate;
  end;
end;

procedure TTrackBar2.SetTickStyle(Value:TTickStyle);
begin
 if Value<>FTickStyle then
  begin
    FTickStyle := Value;
    if FTickStyle = tiLine then TickColor := clBlack; {so is visible}
    UpdateTickData;
    Invalidate;
  end;
end;

procedure TTrackBar2.SetTickColor(Value:TColor);
begin
  if Value<>FTickColor then
  begin
    FTickColor := Value;
    UpdateTickData;
    Invalidate;
  end;
end;

procedure TTrackBar2.SetTickOrientation(Value:TTickOrientation);
begin
 if Value<>FTickOrientation then
  begin
    FTickOrientation := Value;
    UpdateThumbData;
    UpdateTrackData;
    Invalidate;
  end;
end;

procedure TTrackBar2.SetTickInterval(Value:Integer);
begin
 if Value<>FTickInterval then
  begin
    FTickInterval := Value;
    Invalidate;
  end;
end;

procedure TTrackBar2.UpdateTickData;
begin
 if FTickStyle in [tiSquare,tiRaisedSquare,tiLoweredSquare] then
  begin
   FTickBmp.Width := FTickSize;
   FTickBmp.Height := FTickSize;
   with FTickBmp do
    begin
      Canvas.Brush.Style := bsSolid;
      Canvas.Brush.Color := FTickColor;
      Canvas.FillRect(Rect(0,0,Width,Height));
      if FTickStyle=tiSquare then
       begin
        Canvas.Pen.Color := clBlack;
        Canvas.Rectangle(0,0,Width,Height);
       end
      else
       begin
        if FTickStyle=tiRaisedSquare then Canvas.Pen.Color := clWhite
        else Canvas.Pen.Color := clBlack;
        Canvas.MoveTo(0,Height-1);
        Canvas.LineTo(0,0);
        Canvas.LineTo(Width-1,0);
        if FTickStyle=tiRaisedSquare then Canvas.Pen.Color := clBlack
        else Canvas.Pen.Color := clWhite;
        Canvas.LineTo(Width-1,Height-1);
        Canvas.LineTo(0,Height-1);
       end;
    end;
  end;
end;

procedure TTrackBar2.UpdateTicks;
var
  X,Y,I:Integer;
begin
  Canvas.Pen.Color := FTickColor;
  if FOrientation=toHorizontal then
   begin
     I := FMin;
     while I<=FMax do
     begin
       X := (FUsablePixels*I) div (FMax-FMin);
       X := X+FThumbHalfSize;
       X := X+FCentering;
       if FTickOrientation in [toTopLeft,toBoth] then
        begin
          Y := 2;
          if FTickStyle=tiLine then
           begin
            Canvas.MoveTo(X,Y);
            Canvas.LineTo(X,Y+FTickSize);
           end
          else
          if FTickStyle=tiUserDrawn then DrawTick(X,Y,I)
          else Canvas.Draw(X-(FTickSize div 2),Y,FTickBmp);
        end;
       if FTickOrientation in [toBottomRight,toBoth] then
        begin
          Y := Height-FTickSize-2;
          if FTickStyle=tiLine then
           begin
            Canvas.MoveTo(X,Y);
            Canvas.LineTo(X,Y+FTickSize);
           end
          else
          if FTickStyle=tiUserDrawn then DrawTick(X,Y,I)
          else Canvas.Draw(X-(FTickSize div 2),Y,FTickBmp);
        end;
       I := I+FTickInterval;
     end;
   end
  else
   begin
     I := FMin;
     while I<=FMax do
     begin
       Y := (FUsablePixels*(FMax-I)) div (FMax-FMin);
       Y := Y+FThumbHalfSize;
       Y := Y+FCentering;
       if FTickOrientation in [toTopLeft,toBoth] then
        begin
         X := 2;
         if FTickStyle=tiLine then
          begin
           Canvas.MoveTo(X,Y);
           Canvas.LineTo(X+FTickSize,Y);
          end
         else
         if FTickStyle=tiUserDrawn then DrawTick(X,Y,I)
         else Canvas.Draw(X,Y-(FTickSize div 2),FTickBmp);
        end;
       if FTickOrientation in [toBottomRight,toBoth] then
        begin
         X := Width-FTickSize-2;
         if FTickStyle=tiLine then
          begin
           Canvas.MoveTo(X,Y);
           Canvas.LineTo(X+FTickSize,Y);
          end
         else
         if FTickStyle=tiUserDrawn then DrawTick(X,Y,I)
         else Canvas.Draw(X,Y-(FTickSize div 2),FTickBmp);
       end;
       I := I+FTickInterval;
     end;
   end;
end;


procedure TTrackBar2.DoEnter;
begin
  inherited DoEnter;
  Invalidate;
end;

procedure TTrackBar2.DoExit;
begin
  inherited DoExit;
  Invalidate;
end;

procedure TTrackBar2.Paint;
begin
 if Assigned(FOnPaint) then OnPaint(Self);
 FXL := MaxInt;
 FYL := MaxInt;
 FXU := MaxInt;
 FYU := MaxInt;
 UpdateTrack;
 UpdateTicks;
 UpdateThumb;
 if Focused then Canvas.DrawFocusRect(ClientRect);
end;

procedure TTrackBar2.Change;
begin
  if Assigned(FOnChange) then OnChange(Self);
end;

procedure TTrackBar2.DrawTrack;
begin
  if Assigned(FOnDrawTrack) then OnDrawTrack(Self,Canvas);
end;

procedure TTrackBar2.DrawThumb(X,Y:Integer);
begin
  if Assigned(FOnDrawThumb) then OnDrawThumb(Self,Canvas,X,Y);
end;

procedure TTrackBar2.DrawTick(X,Y,Position:Integer);
begin
  if Assigned(FOnDrawTick) then OnDrawTick(Self,Canvas,X,Y,Position);
end;

constructor TTrackBar2.Create(AOwner:TComponent);
begin
  inherited Create(AOwner);
  FMax := 20;
  FMin := 0;
  FSmallChange := 1;
  FLargeChange := 2;

  FOrientation := toVertical;
  FTrackSize := 10;
  FTrackStyle := trLowered;
  FTrackColor := clWhite;
  Width := 500;
  Height := 50;

  FTickSize := 6;
  FTickStyle := tiRaisedSquare;
  FTickColor := clBtnFace;
  FTickOrientation := toBoth;
  FTickInterval := 1;

  FPositionL := 0;
  FPositionU := 10;
  FThumbSize := 20;
  FThumbStyle := tsRaisedRectangle;
  FThumbColor := clBtnFace;
 FSecondThumb := False;
  FXL := MaxInt;
  FYL := MaxInt;
  FXU := MaxInt;
  FYU := MaxInt;

  FDitherThumb := True;
  FTrackingL := False;
  FTrackingU := False;

  TabStop := True;

  FBackgroundBmpL := TBitmap.Create;
  FBackgroundBmpU := TBitmap.Create;
  FBackgroundBmpM := TBitmap.create;
  FThumbBmp       := TBitmap.Create;
  FMaskBmp        := TBitmap.Create;
  FTickBmp        := TBitmap.Create;
  FDitherBmp      := TBitmap.Create;
  FDitherBmp.Width := 8;
  FDitherBmp.Height := 8;
  UpdateThumbData;
  UpdateTrackData;
  UpdateTickData;
  UpdateDitherBitmap;
end;

destructor TTrackBar2.Destroy;
begin
  FThumbBmp.Free;
  FThumbBmp := nil;
  FBackgroundBmpU.Free;
  FBackgroundBmpU := nil;
  FBackgroundBmpL.Free;
  FBackgroundBmpL := nil;
  FBackgroundBmpM.Free;
  FBackgroundBmpM := nil;
  FMaskBmp.Free;
  FMaskBmp := nil;
  FTickBmp.Free;
  FTickBmp := nil;
  FDitherBmp.Free;
  FDitherBmp := nil;
  inherited Destroy;
end;

procedure Register;
begin
  RegisterComponents('Mine', [TTrackBar2]);
end;

end.

diese hab ich schon dahingehend abgeändert das sie meinen Wünschen schon sehr nahe kommt aber es gibt noch Probleme

wenn ich Regler1 über Regler2 schiebe und danach Regler2 bedienen will springt leider nur Regler1 auf die Mausposition(Regler2)

Meine Änderungen am Code

Delphi-Quellcode:

procedure TTrackBar2.SetPositionL(Value: Integer);
begin
  if (Value <> FPositionL) then
  begin
    FPositionL := Value;
    if (FPositionL > FMax) then
      FPositionL := FMax
    else if (FPositionL < FMin) then
      FPositionL := FMin;
    Change;
    if csDesigning in ComponentState then
      Invalidate
    else
      UpdateThumb;
  end;
end;

procedure TTrackBar2.SetPositionU(Value: Integer);
begin
  if (Value <> FPositionU) then
  begin
    FPositionU := Value;
    if (FPositionU > FMax) then
      FPositionU := FMax
    else if (FPositionU < FMin) then
      FPositionU := FMin;
    Change;
    if csDesigning in ComponentState then
      Invalidate
    else
      UpdateThumb;
  end;
end;

Hat jemand was auf Lager oder einen Tip

Edit: und wie kann man hier den Code "eingeklappt" einfügen ist ja doch recht lang