{================================================================

    XiTrackBar 1.01
    Written by Eugene Genev

=================================================================}


unit XiTrackBar;

interface

uses
  Windows, Classes, Controls, Graphics, Messages, Forms, Dialogs,
  Math, SysUtils, ExtCtrls, ComCtrls;

type
  TColorScheme = (csCustom, csDesert, csGrass, csSilver, csSky, csRose, csSun);
  TBtnState = (bsUp, bsOver, bsDown, bsOut);
  TFillDirection = (fdHorizontal, fdVertical, fdDiagonal);
  TXiTrackBar = class(TCustomControl)
  private
    FBackColor: TColor;
    FTickColor: TColor;
    FDisabledTickColor: TColor;
    FSlideBorderColor: TColor;
    FSlideFaceColor: TColor;
    FSlideGradColor: TColor;
    FDisabledSlideBorderColor: TColor;
    FDisabledSlideFaceColor: TColor;
    FDisabledSlideGradColor: TColor;
    FThumbBorderColor: TColor;
    FThumbFaceColor: TColor;
    FThumbGradColor: TColor;
    FOverThumbBorderColor: TColor;
    FOverThumbFaceColor: TColor;
    FOverThumbGradColor: TColor;
    FDownThumbBorderColor: TColor;
    FDownThumbFaceColor: TColor;
    FDownThumbGradColor: TColor;
    FDisabledThumbBorderColor: TColor;
    FDisabledThumbFaceColor: TColor;
    FDisabledThumbGradColor: TColor;

    FColorScheme: TColorScheme;
    FPosition: Integer;
    FMin: Integer;
    FMax: Integer;
    FFrequency: Integer;
    FOrientation: TTrackBarOrientation;
    FTickMarks: TTickMark;
    FTickStyle: TTickStyle;
    FSmoothCorners: Boolean;
    FOnChange: TNotifyEvent;

    FThumbState: TBtnState;
    FSlideRect: TRect;
    FThumbRect: TRect;
    FAbsLength: Integer;
    FAbsPos: Integer;
    FThumbWidth: Integer;
    FThumbLength: Integer;

    procedure SetColors(Index: Integer; Value: TColor);
    procedure SetPosition(Value: Integer);
    procedure SetMin(Value: Integer);
    procedure SetMax(Value: Integer);
    procedure SetFrequency(Value: Integer);
    procedure SetThumbLength(Value: Integer);
    procedure SetThumbWidth(Value: Integer);
    procedure SetTickStyle(Value: TTickStyle);
    procedure SetTickMarks(Value: TTickMark);
    procedure SetOrientation(Value: TTrackBarOrientation);
    procedure SetSmoothCorners(Value: Boolean);
    procedure SetColorScheme(Value: TColorScheme);
    function PointInRect(X, Y: Integer; R: TRect): Boolean;
  protected
    constructor Create(AOwner: TComponent); override;
    procedure Paint; override;
    procedure MouseEnter(var msg: TMessage); message CM_MOUSEENTER;
    procedure MouseLeave(var msg: TMessage); message CM_MOUSELEAVE;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
    procedure MouseMove (Shift: TShiftState; X, Y: Integer); override;
    procedure Resize; override;
    procedure CMEnabledChanged (var msg: TMessage); message CM_ENABLEDCHANGED;
  public
    procedure GradientFillRect(Canvas: TCanvas; Rect: TRect;
                StartColor, EndColor: TColor; Direction: TFillDirection);
    function GetColorScheme: TStringList;
  published
    property BackColor: TColor index 0 read FBackColor write SetColors;
    property TickColor: TColor index 1 read FTickColor write SetColors;
    property DisabledTickColor: TColor index 2 read FDisabledTickColor write SetColors;
    property SlideBorderColor: TColor index 10 read FSlideBorderColor write SetColors;
    property SlideFaceColor: TColor index 11 read FSlideFaceColor write SetColors;
    property SlideGradColor: TColor index 12 read FSlideGradColor write SetColors;
    property DisabledSlideBorderColor: TColor index 13 read FDisabledSlideBorderColor write SetColors;
    property DisabledSlideFaceColor: TColor index 14 read FDisabledSlideFaceColor write SetColors;
    property DisabledSlideGradColor: TColor index 15 read FDisabledSlideGradColor write SetColors;
    property DisabledThumbBorderColor: TColor index 16 read FDisabledThumbBorderColor write SetColors;
    property DisabledThumbFaceColor: TColor index 17 read FDisabledThumbFaceColor write SetColors;
    property DisabledThumbGradColor: TColor index 18 read FDisabledThumbGradColor write SetColors;
    property ThumbBorderColor: TColor index 20 read FThumbBorderColor write SetColors;
    property ThumbFaceColor: TColor index 21 read FThumbFaceColor write SetColors;
    property ThumbGradColor: TColor index 22 read FThumbGradColor write SetColors;
    property OverThumbBorderColor: TColor index 30 read FOverThumbBorderColor write SetColors;
    property OverThumbFaceColor: TColor index 31 read FOverThumbFaceColor write SetColors;
    property OverThumbGradColor: TColor index 32 read FOverThumbGradColor write SetColors;
    property DownThumbBorderColor: TColor index 40 read FDownThumbBorderColor write SetColors;
    property DownThumbFaceColor: TColor index 41 read FDownThumbFaceColor write SetColors;
    property DownThumbGradColor: TColor index 42 read FDownThumbGradColor write SetColors;
    property SmoothCorners: Boolean read FSmoothCorners write SeTSmoothCorners;
    property ColorScheme: TColorScheme read FColorScheme write SetColorScheme;
    property Position: Integer read FPosition write SetPosition;
    property Min: Integer read FMin write SetMin;
    property Max: Integer read FMax write SetMax;
    property Frequency: Integer read FFrequency write SetFrequency;
    property TickStyle: TTickStyle read FTickStyle write SetTickStyle;
    property TickMarks: TTickMark read FTickMarks write SetTickMarks;
    property Orientation: TTrackBarOrientation read FOrientation write SetOrientation;

    property Align;
    property Anchors;
    property BorderWidth;
    property Constraints;
    property Ctl3D;
    property Cursor;
    property DragCursor;
    property DragKind;
    property DragMode;
    property Enabled;
    property HelpContext;
  //  property HelpKeyword;
  //  property HelpType;
    property Hint;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    // property TabOrder;
    // property TabStop;
    property Tag;
    property Visible;

    property OnChange: TNotifyEvent read FOnChange write FOnChange;
end;


procedure Register;

{//$R XiTrackBar.res}

implementation

procedure Register;
begin
  RegisterComponents('XiControls', [TXiTrackBar]);
end;

constructor TXiTrackBar.Create(AOwner: TComponent);
begin
  inherited;
  Width:= 100;
  Height:= 28;
  FThumbLength:= 20;
  FThumbWidth:= 10;
  FMin:= 0;
  FMax:= 10;
  FFrequency:= 1;
  FSmoothCorners:= true;
  FBackColor:= clBtnFace;
  ColorScheme:= csDesert;
  
  FThumbState:= bsOut;
end;

procedure TXiTrackBar.Paint;
var
  SlideBorderColor, SlideFaceColor, SlideGradColor, TickColor: TColor;
  ThumbBorderColor, ThumbFaceColor, ThumbGradColor: TColor;
  ScrBmp: TBitmap;
  i: integer;
begin
  SlideBorderColor:= FSlideBorderColor;
  SlideFaceColor:= FSlideFaceColor;
  SlideGradColor:= FSlideGradColor;
  TickColor:= FTickColor;
  Color:= FBackColor;

  case FThumbState of
    bsOut:    begin
                ThumbBorderColor:= FThumbBorderColor;
                ThumbFaceColor:= FThumbFaceColor;
                ThumbGradColor:= FThumbGradColor;
              end;
    bsOver:   begin
                ThumbBorderColor:= FOverThumbBorderColor;
                ThumbFaceColor:= FOverThumbFaceColor;
                ThumbGradColor:= FOverThumbGradColor;
              end;
    bsDown:   begin
                ThumbBorderColor:= FDownThumbBorderColor;
                ThumbFaceColor:= FDownThumbFaceColor;
                ThumbGradColor:= FDownThumbGradColor;
              end;
  end;

  if not Enabled then begin
    SlideBorderColor:= FDisabledSlideBorderColor;
    SlideFaceColor:= FDisabledSlideFaceColor;
    SlideGradColor:= FDisabledSlideGradColor;
    ThumbBorderColor:= FDisabledThumbBorderColor;
    ThumbFaceColor:= FDisabledThumbFaceColor;
    ThumbGradColor:= FDisabledThumbGradColor;
    TickColor:= FDisabledTickColor;
  end;

  ScrBmp:= TBitmap.Create;
  ScrBmp.Width:= ClientWidth;
  ScrBmp.Height:= ClientHeight;

  ScrBmp.Canvas.Brush.Style:= bsSolid;
  ScrBmp.Canvas.Brush.Color:= Color;
  ScrBmp.Canvas.Rectangle(-1, -1, ScrBmp.Width+1, ScrBmp.Height+1);

  if FOrientation = trHorizontal then begin
    FThumbLength:= ClientHeight - 8;
    FThumbWidth:= FThumbLength div 2;
    FAbsLength:= ClientWidth - FThumbWidth;

    FThumbRect.Top:= 4;
    FThumbRect.Bottom:= FThumbRect.Top + FThumbLength;
    FThumbRect.Left:= FAbsPos;
    FThumbRect.Right:= FThumbRect.Left + (FThumbRect.Bottom - FThumbRect.Top) div 2;

    FSlideRect.Left:= 0;
    FSlideRect.Right:= ClientWidth;
    FSlideRect.Top:= ClientHeight div 3 + 1;
    FSlideRect.Bottom:= ClientHeight - FSlideRect.Top;
  end else begin
    FThumbLength:= ClientWidth - 8;
    FThumbWidth:= FThumbLength div 2;
    FAbsLength:= ClientHeight - FThumbWidth;

    FPosition:= Round(FAbsPos * (FMax - FMin) / FAbsLength) + FMin;
    FAbsPos:= Round((FAbsLength / (FMax - FMin)) * (FPosition - FMin));

    FThumbRect.Left:= 4;
    FThumbRect.Right:= FThumbRect.Left + FThumbLength;
    FThumbRect.Top:= FAbsPos;
    FThumbRect.Bottom:= FThumbRect.Top + FThumbWidth;

    FSlideRect.Left:= ClientWidth div 3 + 1;
    FSlideRect.Right:= ClientWidth - FSlideRect.Left;
    FSlideRect.Top:= 0;
    FSlideRect.Bottom:= ClientHeight;
  end;


  with ScrBmp.Canvas do begin
    Brush.Style:= bsClear;

    if FOrientation = trHorizontal then GradientFillRect(ScrBmp.Canvas, FSlideRect, SlideFaceColor, SlideGradColor, fdVertical)
    else GradientFillRect(ScrBmp.Canvas, FSlideRect, SlideFaceColor, SlideGradColor, fdHorizontal);

    Pen.Color:= SlideBorderColor;
    Rectangle(FSlideRect.Left, FSlideRect.Top, FSlideRect.Right, FSlideRect.Bottom);

    if FSmoothCorners then begin
      Pixels[FSlideRect.Left, FSlideRect.Top]:= FBackColor;
      Pixels[FSlideRect.Left, FSlideRect.Bottom-1]:= FBackColor;
      Pixels[FSlideRect.Right-1, FSlideRect.Top]:= FBackColor;
      Pixels[FSlideRect.Right-1, FSlideRect.Bottom-1]:= FBackColor;
    end;

    if FOrientation = trHorizontal then GradientFillRect(ScrBmp.Canvas, FThumbRect, ThumbFaceColor, ThumbGradColor, fdHorizontal)
    else GradientFillRect(ScrBmp.Canvas, FThumbRect, ThumbFaceColor, ThumbGradColor, fdVertical);

    Pen.Color:= ThumbBorderColor;
    Rectangle(FThumbRect.Left, FThumbRect.Top, FThumbRect.Right, FThumbRect.Bottom);

    if FSmoothCorners then begin
      Pixels[FThumbRect.Left, FThumbRect.Top]:= FBackColor;
      Pixels[FThumbRect.Left, FThumbRect.Bottom-1]:= FBackColor;
      Pixels[FThumbRect.Right-1, FThumbRect.Top]:= FBackColor;
      Pixels[FThumbRect.Right-1, FThumbRect.Bottom-1]:= FBackColor;
    end;

    for i:= 0 to (FMax-FMin) do begin
      if FTickStyle = tsNone then break;
      if FTickStyle = tsManual then if not ((i = 0) or (i = FMax-FMin)) then continue;
      if not ((i = FMax-FMin)) then if FFrequency <> 0 then if i div FFrequency * FFrequency <> i then continue;

      Pen.Color:= TickColor;
      if FOrientation = trHorizontal then begin
        if (FTickMarks = tmTopLeft) or (FTickMarks = tmBoth) then begin
          MoveTo(Round(FAbsLength * i / (FMax - FMin) + FThumbWidth / 2), 0);
          LineTo(Round(FAbsLength * i / (FMax - FMin) + FThumbWidth / 2), 3);
        end;
        if (FTickMarks = tmBottomRight) or (FTickMarks = tmBoth) then begin
          MoveTo(Round(FAbsLength * i / (FMax - FMin)) + FThumbWidth div 2, ScrBmp.Height-3);
          LineTo(Round(FAbsLength * i / (FMax - FMin)) + FThumbWidth div 2, ScrBmp.Height);
        end;
      end else begin
        if (FTickMarks = tmTopLeft) or (FTickMarks = tmBoth) then begin
          MoveTo(0, Round(FAbsLength * i / (FMax - FMin)) + (FThumbRect.Bottom - FThumbRect.Top) div 2);
          LineTo(3, Round(FAbsLength * i / (FMax - FMin)) + (FThumbRect.Bottom - FThumbRect.Top) div 2);
        end;
        if (FTickMarks = tmBottomRight) or (FTickMarks = tmBoth) then begin
          MoveTo(ScrBmp.Width-3, Round(FAbsLength * i / (FMax - FMin)) + (FThumbRect.Bottom - FThumbRect.Top) div 2);
          LineTo(ScrBmp.Width, Round(FAbsLength * i / (FMax - FMin)) + (FThumbRect.Bottom - FThumbRect.Top) div 2);
        end;
      end;
    end;
  end;

  Canvas.Draw(0, 0, ScrBmp);
  ScrBmp.Free;
end;

procedure TXiTrackBar.MouseEnter(var msg: TMessage);
begin
  Paint;
end;

procedure TXiTrackBar.MouseLeave(var msg: TMessage);
begin
  if not Enabled then Exit;
  if FThumbState <> bsDown then FThumbState:= bsOut;
  Paint;
end;

procedure TXiTrackBar.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  if not Enabled then Exit;
  if PointInRect(X, Y, FThumbRect) then FThumbState:= bsDown;
  Paint;
end;

procedure TXiTrackBar.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  if not Enabled then Exit;
  if PointInRect(X, Y, FThumbRect) then FThumbState:= bsOver
  else FThumbState:= bsOut;
  Paint;
end;

procedure TXiTrackBar.MouseMove(Shift: TShiftState; X, Y: Integer);
begin
  if not Enabled then Exit;
  if FThumbState <> bsDown then
    if PointInRect(X, Y, FThumbRect) then FThumbState:= bsOver
    else FThumbState:= bsOut;

  if FThumbState = bsDown then begin
    if FOrientation = trHorizontal then begin
      FAbsPos:= X - FThumbWidth div 2;
      if FAbsPos < 0 then FAbsPos:= 0;
      if FAbsPos > FAbsLength then FAbsPos:= FAbsLength;
    end else begin