vrswitch.pas

作工控的好控件

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

unit VrSwitch;

{$I VRLIB.INC}

interface

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

type
  TVrSwitchOption = (soActiveClick, soMouseClip, soHandPoint, soThumbOpaque);
  TVrSwitchOptions = set of TVrSwitchOption;

  TVrSwitch = class(TVrCustomImageControl)
  private
    FOffset: Integer;
    FPositions: Integer;
    FOrientation: TVrOrientation;
    FBevel: TVrBevel;
    FStyle: TVrProgressStyle;
    FOptions: TVrSwitchOptions;
    FBorderColor: TColor;
    FBorderWidth: Integer;
    FFocusColor: TColor;
    FBackImageIndex: Integer;
    FThumbImageIndex: Integer;
    FBitmapList: TVrBitmapList;
    FBitmapListLink: TVrChangeLink;
    FOnChange: TNotifyEvent;
    FHit: Integer;
    FFocused: Boolean;
    FClipOn: Boolean;
    FThumbRect: TRect;
    FThumbWidth: Integer;
    FThumbHeight: Integer;
    FThumbImage: TBitmap;
    FThumbStates: TVrNumGlyphs;
    FThumbIndent: Integer;
    FThumbDown: Boolean;
    FThumbHasMouse: Boolean;
    procedure SetThumbStates(Value: TVrNumGlyphs);
    procedure SetThumbIndent(Value: Integer);
    procedure SetOrientation(Value: TVrOrientation);
    procedure SetOffset(Value: Integer);
    procedure SetPositions(Value: Integer);
    procedure SetStyle(Value: TVrProgressStyle);
    procedure SetOptions(Value: TVrSwitchOptions);
    procedure SetBorderColor(Value: TColor);
    procedure SetBorderWidth(Value: Integer);
    procedure SetFocusColor(Value: TColor);
    procedure SetBevel(Value: TVrBevel);
    procedure SetBackImageIndex(Value: Integer);
    procedure SetThumbImageIndex(Value: Integer);
    procedure SetBitmapList(Value: TVrBitmapList);
    procedure BevelChanged(Sender: TObject);
    procedure BitmapListChanged(Sender: TObject);
    procedure AdjustControlSize;
    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 SetThumbTop(ATop: Integer);
    procedure SetThumbLeft(ALeft: Integer);
    procedure CenterThumb;
    procedure Paint; override;
    procedure PaintThumb;
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    procedure CreateParams(var Params: TCreateParams); override;
    procedure GetThumbImage;
    procedure Change; dynamic;
    function GetBitmap(Index: Integer): TBitmap;
    function GetViewWidth: Integer;
    function GetOffsetByValue(Value: Integer): Integer;
    function GetValueByOffset(Offset: Integer): Integer;
    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 Positions: Integer read FPositions write SetPositions default 4;
    property Offset: Integer read FOffset write SetOffset default 0;
    property Orientation: TVrOrientation read FOrientation write SetOrientation default voVertical;
    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 ThumbStates: TVrNumGlyphs read FThumbStates write SetThumbStates default 1;
    property ThumbIndent: Integer read FThumbIndent write SetThumbIndent default 1;
    property Style: TVrProgressStyle read FStyle write SetStyle default psBottomLeft;
    property Bevel: TVrBevel read FBevel write SetBevel;
    property Options: TVrSwitchOptions read FOptions write SetOptions
      default [soActiveClick, soMouseClip, soHandPoint, soThumbOpaque];
    property BorderColor: TColor read FBorderColor write SetBorderColor default clBtnFace;
    property BorderWidth: Integer read FBorderWidth write SetBorderWidth default 1;
    property FocusColor: TColor read FFocusColor write SetFocusColor default clBlue;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
{$IFDEF VER110}
    property Anchors;
    property Constraints;
{$ENDIF}
    property Color default clBlack;
    property ParentColor default false;
    property DragCursor;
{$IFDEF VER110}
    property DragKind;
{$ENDIF}
    property DragMode;
    property Enabled;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property TabOrder;
    property TabStop default False;
    property Visible;
    property OnClick;
{$IFDEF VER130}
    property OnContextPopup;
{$ENDIF}
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnDragDrop;
    property OnDragOver;
{$IFDEF VER110}
    property OnEndDock;
{$ENDIF}
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
{$IFDEF VER110}
    property OnStartDock;
{$ENDIF}
    property OnStartDrag;
  end;


implementation

{$R VRSWITCH.D32}

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


{ TVrSwitch }

constructor TVrSwitch.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle := ControlStyle + [csOpaque] - [csSetCaption];
  Width := 29;
  Height := 60;
  Tabstop := False;
  Color := clBlack;
  ParentColor := false;
  FPositions := 4;
  FOffset := 0;
  FOrientation := voVertical;
  FOptions := [soActiveClick, soMouseClip, soHandPoint, soThumbOpaque];
  FStyle := psBottomLeft;
  FBorderColor := clBtnFace;
  FBorderWidth := 1;
  FFocusColor := clBlue;
  FBevel := TVrBevel.Create;
  with FBevel do
  begin
    InnerSpace := 0;
    OuterOutline := osNone;
    OnChange := BevelChanged;
  end;
  FBackImageIndex := -1;
  FThumbImageIndex := -1;
  FBitmapListLink := TVrChangeLink.Create;
  FBitmapListLink.OnChange := BitmapListChanged;
  FThumbStates := 1;
  FThumbIndent := 1;
  FThumbImage := TBitmap.Create;
  GetThumbImage;
end;

destructor TVrSwitch.Destroy;
begin
  FThumbImage.Free;
  FBevel.Free;
  FBitmapListLink.Free;
  inherited Destroy;
end;

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

procedure TVrSwitch.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;
  AdjustControlSize;
  CenterThumb;
end;

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

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

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

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

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

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

function TVrSwitch.GetOffsetByValue(Value: Integer): Integer;
var
  Range: Double;
  R: TRect;
  MinIndent: Integer;
begin
  R := GetSliderRect;
  MinIndent := GetMinIndent(R);
  Range := Positions - 1;
  Result := Round(Value / 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 TVrSwitch.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 := Positions - 1;
  Result := Round((Offset - MinIndent) * Range / GetViewWidth);
  Result := MinIntVal(MaxIntVal(Result, 0), Positions - 1);
end;

procedure TVrSwitch.SetThumbOffset(Value: Integer);
var
  R: TRect;
  MinIndent: Integer;
begin
  R := GetSliderRect;
  MinIndent := GetMinIndent(R);
  Value := MinIntVal(MaxIntVal(Value, MinIndent),
    MinIndent + GetViewWidth);
  if FStyle = psBottomLeft then Offset := GetValueByOffset(Value)
  else Offset := Pred(Positions) - GetValueByOffset(Value);
end;

procedure TVrSwitch.BitmapListChanged(Sender: TObject);
begin
  GetThumbImage;
  UpdateControlCanvas;
end;

procedure TVrSwitch.BevelChanged(Sender: TObject);
begin
  UpdateControlCanvas;
end;

procedure TVrSwitch.Paint;
var
  R: TRect;
  aGlyph: TBitmap;
  Value: Integer;
  CurrentColor: TColor;
begin
  ClearBitmapCanvas;
  R := ClientRect;
  if BorderWidth > 0 then
  begin
    if FFocused then CurrentColor := FFocusColor
    else CurrentColor := FBorderColor;
    DrawFrame3D(BitmapCanvas, R,
      CurrentColor, CurrentColor, BorderWidth);
  end;

  FBevel.Paint(BitmapCanvas, R);
  aGlyph := GetBitmap(BackImageIndex);
  if aGlyph <> nil then BitmapCanvas.StretchDraw(R, aGlyph);

  Value := GetOffsetByValue(Offset);
  if Orientation = voVertical then