vrtrackbar.pas

作工控的好控件

{*****************************************************}
{                                                     }
{     Varian Component Workshop                       }
{                                                     }
{     Varian Software NL (c) 1996-2000                }
{     All Rights Reserved                             }
{                                                     }
{*****************************************************}

unit VrTrackBar;

{$I VRLIB.INC}

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  VrConst, VrTypes, VrClasses, VrControls, VrSysUtils, VrSystem;


type
  TVrTrackBarOption = (toActiveClick, toMouseClip, toHandPoint,
    toFixedPoints, toThumbOpaque);
  TVrTrackBarOptions = set of TVrTrackBarOption;

  TVrTrackBar = class(TVrCustomImageControl)
  private
    FMinValue: Integer;
    FMaxValue: Integer;
    FPosition: Integer;
    FStyle: TVrProgressStyle;
    FOrientation: TVrOrientation;
    FOptions: TVrTrackBarOptions;
    FFrequency: Integer;
    FBorderWidth: Integer;
    FGutterBevel: TVrBevel;
    FGutterWidth: Integer;
    FGutterColor: TColor;
    FTickMarks: TVrTickMarks;
    FTickColor: TColor;
    FScaleOffset: Integer;
    FFocusColor: TColor;
    FFocusOffset: Integer;
    FBackImageIndex: Integer;
    FThumbImageIndex: Integer;
    FBitmapList: TVrBitmapList;
    FBitmapListLink: TVrChangeLink;
    FOnChange: TNotifyEvent;
    FHit: Integer;
    FClipOn: Boolean;
    FFocused: Boolean;
    FThumbRect: TRect;
    FThumbWidth: Integer;
    FThumbHeight: Integer;
    FThumbImage: TBitmap;
    FThumbDown: Boolean;
    FThumbHasMouse: Boolean;
    FThumbStates: TVrNumGlyphs;
    procedure SetMinValue(Value: Integer);
    procedure SetMaxValue(Value: Integer);
    procedure SetPosition(Value: Integer);
    procedure SetStyle(Value: TVrProgressStyle);
    procedure SetOrientation(Value: TVrOrientation);
    procedure SetOptions(Value: TVrTrackBarOptions);
    procedure SetFrequency(Value: Integer);
    procedure SetBorderWidth(Value: Integer);
    procedure SetGutterWidth(Value: Integer);
    procedure SetGutterColor(Value: TColor);
    procedure SetGutterBevel(Value: TVrBevel);
    procedure SetTickMarks(Value: TVrTickMarks);
    procedure SetTickColor(Value: TColor);
    procedure SetScaleOffset(Value: Integer);
    procedure SetThumbStates(Value: TVrNumGlyphs);
    procedure SetFocusColor(Value: TColor);
    procedure SetFocusOffset(Value: Integer);
    procedure SetBackImageIndex(Value: Integer);
    procedure SetThumbImageIndex(Value: Integer);
    procedure SetBitmapList(Value: TVrBitmapList);
    procedure DrawScale(Canvas: TCanvas; Offset, ThumbOffset,
      RulerLength, PointsStep, PointsHeight, ExtremePointsHeight: Integer);
    procedure GutterBevelChanged(Sender: TObject);
    procedure BitmapListChanged(Sender: TObject);
    procedure WMSize(var Message: TWMSize); message WM_SIZE;
    procedure WMSetCursor(var Message: TWMSetCursor); message WM_SETCURSOR;
    procedure WMGetDlgCode(var Msg: TWMGetDlgCode); message WM_GETDLGCODE;
    procedure CMFocusChanged(var Message: TCMFocusChanged); message CM_FOCUSCHANGED;
    procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED;
  protected
    procedure CreateParams(var Params: TCreateParams); override;
    procedure GetThumbImage;
    procedure SetThumbTop(ATop: Integer);
    procedure SetThumbLeft(ALeft: Integer);
    procedure CenterThumb;
    procedure Paint; override;
    procedure PaintThumb;
    procedure Change; dynamic;
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    function GetViewWidth: Integer;
    function GetOffsetByValue(Value: Integer): Integer;
    function GetValueByOffset(Offset: Integer): Integer;
    function GetBitmap(Index: Integer): TBitmap;
    function GetSliderRect: TRect;
    function GetMinIndent(Rect: TRect): Integer;
    procedure SetThumbOffset(Value: Integer);
    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 KeyDown(var Key: Word; Shift: TShiftState); override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property MaxValue: Integer read FMaxValue write SetMaxValue default 100;
    property MinValue: Integer read FMinValue write SetMinValue default 0;
    property Position: Integer read FPosition write SetPosition default 0;
    property Orientation: TVrOrientation read FOrientation write SetOrientation default voHorizontal;
    property Style: TVrProgressStyle read FStyle write SetStyle default psBottomLeft;
    property Options: TVrTrackBarOptions read FOptions write SetOptions
      default [toActiveClick, toMouseClip, toHandPoint, toThumbOpaque];
    property Frequency: Integer read FFrequency write SetFrequency default 10;
    property BorderWidth: Integer read FBorderWidth write SetBorderWidth default 10;
    property GutterBevel: TVrBevel read FGutterBevel write SetGutterBevel;
    property GutterWidth: Integer read FGutterWidth write SetGutterWidth default 9;
    property GutterColor: TColor read FGutterColor write SetGutterColor default clBlack;
    property TickMarks: TVrTickMarks read FTickMarks write SetTickMarks default tmBoth;
    property TickColor: TColor read FTickColor write SetTickColor default clBlack;
    property ThumbStates: TVrNumGlyphs read FThumbStates write SetThumbStates default 1;
    property BackImageIndex: Integer read FBackImageIndex write SetBackImageIndex default -1;
    property ThumbImageIndex: Integer read FThumbImageIndex write SetThumbImageIndex default -1;
    property BitmapList: TVrBitmapList read FBitmapList write SetBitmapList;
    property ScaleOffset: Integer read FScaleOffset write SetScaleOffset default 5;
    property FocusColor: TColor read FFocusColor write SetFocusColor default clBlack;
    property FocusOffset: Integer read FFocusOffset write SetFocusOffset default 0;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
    property Align;
{$IFDEF VER110}
    property Anchors;
    property Constraints;
{$ENDIF}
    property Enabled;
    property Color;
    property Cursor;
    property DragMode;
{$IFDEF VER110}
    property DragKind;
{$ENDIF}
    property DragCursor;
    property ParentColor;
    property ParentShowHint;
    property ShowHint;
    property TabOrder;
    property TabStop default false;
    property Visible;
    property OnClick;
{$IFDEF VER130}
    property OnContextPopup;
{$ENDIF}
    property OnEnter;
    property OnExit;
    property OnMouseMove;
    property OnMouseDown;
    property OnMouseUp;
    property OnKeyDown;
    property OnKeyUp;
    property OnKeyPress;
    property OnDragOver;
{$IFDEF VER110}
    property OnEndDock;
{$ENDIF}
    property OnDragDrop;
    property OnEndDrag;
{$IFDEF VER110}
    property OnStartDock;
{$ENDIF}
    property OnStartDrag;
  end;


implementation

{$R VRTRACKBAR.D32}

const
  ThumbNames: array[0..1] of PChar =
    ('VRTB_VERT', 'VRTB_HORI');


{ TVrTrackBar }

constructor TVrTrackBar.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle := ControlStyle + [csOpaque];
  Width := 175;
  Height := 45;
  TabStop := false;
  FMinValue := 0;
  FMaxValue := 100;
  FPosition := 0;
  FStyle := psBottomLeft;
  FOrientation := voHorizontal;
  FOptions := [toActiveClick, toMouseClip, toHandPoint, ToThumbOpaque];
  FFrequency := 10;
  FBorderWidth := 10;
  FTickMarks := tmBoth;
  FTickColor := clBlack;
  FScaleOffset := 5;
  FFocusColor := clBlack;
  FFocusOffset := 0;
  FGutterWidth := 9;
  FGutterColor := clBlack;
  FGutterBevel := TVrBevel.Create;
  with FGutterBevel do
  begin
    InnerStyle := bsNone;
    InnerSpace := 0;
    InnerOutline := osNone;
    OuterStyle := bsLowered;
    OuterSpace := 0;
    OuterOutline := osNone;
    OnChange := GutterBevelChanged;
  end;
  FBackImageIndex := -1;
  FThumbImageIndex := -1;
  FBitmapListLink := TVrChangeLink.Create;
  FBitmapListLink.OnChange := BitmapListChanged;
  FThumbImage := TBitmap.Create;
  FThumbStates := 1;
  GetThumbImage;
end;

destructor TVrTrackBar.Destroy;
begin
  FThumbImage.Free;
  FGutterBevel.Free;
  FBitmapListLink.Free;
  inherited Destroy;
end;

procedure TVrTrackBar.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  with Params do
    WindowClass.style := WindowClass.style and not (CS_HREDRAW or CS_VREDRAW);
end;

procedure TVrTrackBar.GetThumbImage;
begin
  FThumbImage.Assign(GetBitmap(FThumbImageIndex));
  if FThumbImage.Empty then
  begin
    if Orientation = voVertical then
    FThumbImage.LoadFromResourceName(hInstance, ThumbNames[0])
    else FThumbImage.LoadFromResourceName(hInstance, ThumbNames[1]);
  end;
  FThumbHeight := FThumbImage.Height;
  FThumbWidth := FThumbImage.Width div ThumbStates;
  CenterThumb;
end;

function TVrTrackBar.GetBitmap(Index: Integer): TBitmap;
begin
  Result := nil;
  if Assigned(FBitmapList) then
    Result := FBitmapList.GetBitmap(Index);
end;

procedure TVrTrackBar.SetThumbLeft(ALeft: Integer);
begin
  FThumbRect := Bounds(ALeft, FThumbRect.Top, FThumbWidth, FThumbHeight);
end;

procedure TVrTrackBar.SetThumbTop(ATop: Integer);
begin
  FThumbRect := Bounds(FThumbRect.Left, ATop, FThumbWidth, FThumbHeight);
end;

procedure TVrTrackBar.CenterThumb;
begin
  if Orientation = voVertical then
    SetThumbLeft((Width - FThumbWidth) div 2)
  else SetThumbTop((Height - FThumbHeight) div 2);
end;

function TVrTrackBar.GetSliderRect: TRect;
begin
  Result := ClientRect;
  InflateRect(Result, -BorderWidth, -BorderWidth);
end;

function TVrTrackBar.GetMinIndent(Rect: TRect): Integer;
begin
  if Orientation = voVertical then
    Result := MaxIntVal(0, Rect.Top)
  else
    Result := MaxIntVal(0, Rect.Left);
end;

function TVrTrackBar.GetViewWidth: Integer;
var
  R: TRect;
begin
  R := GetSliderRect;
  if Orientation = voVertical then
  Result := HeightOf(R) - FThumbHeight
  else Result := WidthOf(R) - FThumbWidth;
end;

function TVrTrackBar.GetOffsetByValue(Value: Integer): Integer;
var
  Range: Double;
  R: TRect;
  MinIndent: Integer;
begin
  R := GetSliderRect;
  MinIndent := GetMinIndent(R);
  Range := MaxValue - MinValue;
  Result := Round((Value - MinValue) / Range * GetViewWidth) + MinIndent;
  if (FOrientation = voVertical) and (FStyle = psBottomLeft) then
    Result := R.Top + R.Bottom - Result - FThumbHeight
  else
  if (FOrientation = voHorizontal) and (FStyle = psTopRight) then
    Result := R.Left + R.Right - Result - FThumbWidth;
end;

function TVrTrackBar.GetValueByOffset(Offset: Integer): Integer;
var
  R: TRect;
  Range: Double;
  MinIndent: Integer;
begin
  R := GetSliderRect;
  MinIndent := GetMinIndent(R);
  if Orientation = voVertical then
    Offset := ClientHeight - Offset - FThumbHeight;

  Range := FMaxValue - FMinValue;
  Result := Round((Offset - MinIndent) * Range / GetViewWidth);

  if (toFixedPoints in Options) then
    Result := Round(Result / Frequency) * Frequency;

  Result := MinIntVal(FMinValue + MaxIntVal(Result, 0), FMaxValue);
end;

procedure TVrTrackBar.SetThumbOffset(Value: Integer);
var
  R: TRect;
  MinIndent: Integer;
begin
  R := GetSliderRect;
  MinIndent := GetMinIndent(R);
  Value := MinIntVal(MaxIntVal(Value, MinIndent),
    MinIndent + GetViewWidth);

  if (toFixedPoints in Options) then
  begin
    if FStyle = psBottomLeft then Value := GetValueByOffset(Value)
    else Value := FMaxValue - GetValueByOffset(Value) + FMinValue;
    Value := MinIntVal(GetOffsetByValue(Value), GetViewWidth);
  end;

  if FStyle = psBottomLeft then Position := GetValueByOffset(Value)
  else Position := FMaxValue - GetValueByOffset(Value) + FMinValue;
end;

procedure TVrTrackBar.Paint;
var
  R: TRect;
  Bmp: TBitmap;
  Offset, Value: Integer;
begin
  with BitmapImage, BitmapCanvas do
  begin
    Bmp := GetBitmap(BackImageIndex);
    if Bmp = nil then
    begin
      Brush.Color := Self.Color;
      FillRect(ClientRect);
    end else StretchDraw(ClientRect, Bmp);

    Pen.Color := TickColor;
    case Orientation of
      voVertical:
        begin
          Offset := (ClientWidth - FGutterWidth) div 2;
          R := Bounds(Offset, BorderWidth, GutterWidth,
            ClientHeight - FBorderWidth * 2);
          if (FTickMarks in [tmBoth, tmTopLeft]) then
            DrawScale(BitmapCanvas, R.Left - FScaleOffset, FThumbHeight div 2,
                      GetViewWidth, Frequency, -3, -4);
          if (FTickMarks in [tmBoth, tmBottomRight]) then
            DrawScale(BitmapCanvas, R.Right + FScaleOffset, FThumbHeight div 2,
                      GetViewWidth, Frequency, 3, 4);
        end;
      voHorizontal:
        begin
          Offset := (ClientHeight - FGutterWidth) div 2;
          R := Bounds(BorderWidth, Offset,
            ClientWidth - FBorderWidth * 2, GutterWidth);
          if (FTickMarks in [tmBoth, tmTopLeft]) then
            DrawScale(BitmapCanvas, R.Top - FScaleOffset, FThumbWidth div 2,
                      GetViewWidth, Frequency, -3, -4);
          if (FTickMarks in [tmBoth, tmBottomRight]) then
            DrawScale(BitmapCanvas, R.Bottom + FScaleOffset, FThumbWidth div 2,
                      GetViewWidth, Frequency, 3, 4);
        end;
    end;

    if GutterBevel.Visible then
    begin
      GutterBevel.Paint(BitmapCanvas, R);
      Brush.Color := GutterColor;
      FillRect(R);
    end;

    if (Focused) and (FocusOffset > -1) then
    begin
      R := ClientRect;
      InflateRect(R, -FocusOffset, -FocusOffset);
      Brush.Color := FocusColor;
      FrameRect(R);
    end;
  end; { Bitmap, BitmapCanvas }

  Value := GetOffsetByValue(Position);
  if Orientation = voVertical then
    SetThumbTop(Value) else SetThumbLeft(Value);
  PaintThumb;
  inherited Paint;
end;

procedure TVrTrackBar.PaintThumb;
var
  Index: Integer;
  SrcRect: TRect;
  TransColor: TColor;