vrnavigator.pas

作工控的好控件

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

unit VrNavigator;

{$I VRLIB.INC}

interface

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

type
  TVrButtonType = (btPower, btPlay, btPause, btStop, btPrev, btBack, btStep,
    btNext, btRecord, btEject);
  TVrButtonSet = set of TVrButtonType;

  TVrNavButton = record
    Visible: Boolean;
    Enabled: Boolean;
  end;

  TVrMediaButton = class(TVrCustomImageControl)
  private
    FButtonType: TVrButtonType;
    FFocusColor: TColor;
    FBorderColor: TColor;
    FEnGlyphs: TBitmap;
    FDiGlyphs: TBitmap;
    Down: Boolean;
    Pressed: Boolean;
    MaskColor: TColor;
    HasFocus: Boolean;
    procedure SetButtonType(Value: TVrButtonType);
    procedure SetFocusColor(Value: TColor);
    procedure SetBorderColor(Value: TColor);
    procedure DoMouseDown(XPos, YPos: Integer);
    procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN;
    procedure WMMouseMove(var Message: TWMMouseMove); message WM_MOUSEMOVE;
    procedure WMLButtonUp(var Message: TWMLButtonUp); message WM_LBUTTONUP;
    procedure WMLButtonDblClk(var Message: TWMLButtonDblClk); message WM_LBUTTONDBLCLK;
    procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED;
    procedure WMSetFocus(var Message: TWMSetFocus); message WM_SETFOCUS;
    procedure WMKillFocus(var Message: TWMKillFocus); message WM_KILLFOCUS;
  protected
    procedure LoadBitmaps;
    procedure Paint; override;
    procedure KeyDown(var Key: Word; Shift: TShiftState); override;
    procedure KeyUp(var Key: Word; Shift: TShiftState); override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property ButtonType: TVrButtonType read FButtonType write SetButtonType default btPause;
    property FocusColor: TColor read FFocusColor write SetFocusColor default clBlue;
    property BorderColor: TColor read FBorderColor write SetBorderColor default clBlack;
{$IFDEF VER110}
    property Anchors;
    property Constraints;
{$ENDIF}
    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;

const
  DefEnabledButtons = [btPower, btPlay, btPause, btStop, btPrev, btBack, btStep,
    btNext, btRecord, btEject];
  DefVisibleButtons = [btPower, btPlay, btPause, btStop, btPrev, btBack, btStep,
    btNext, btRecord, btEject];

type
  TVrClickEvent = procedure (Sender: TObject; Button: TVrButtonType) of object;

  TVrNavigator = class(TVrCustomImageControl)
  private
    FVisibleButtons: TVrButtonSet;
    FEnabledButtons: TVrButtonSet;
    FBevel: TVrBevel;
    FFocusColor: TColor;
    FBorderColor: TColor;
    FSpacing: Integer;
    FEnGlyphs: TBitmap;
    FDiGlyphs: TBitmap;
    FNumeric: Boolean;
    FOrientation: TVrOrientation;
    FOnButtonClick: TVrClickEvent;
    Bitmap: TBitmap;
    Pressed: Boolean;
    Down: Boolean;
    CurrentButton: TVrButtonType;
    ViewPort: TRect;
    ButtonWidth: Integer;
    ButtonHeight: Integer;
    FocusedButton: TVrButtonType;
    Buttons: array[TVrButtonType] of TVrNavButton;
    function VisibleButtonCount: Integer;
    procedure SetVisibleButtons(Value: TVrButtonSet);
    procedure SetEnabledButtons(Value: TVrButtonSet);
    procedure SetSpacing(Value: Integer);
    procedure SetFocusColor(Value: TColor);
    procedure SetBorderColor(Value: TColor);
    procedure SetOrientation(Value: TVrOrientation);
    procedure SetNumeric(Value: Boolean);
    procedure SetBevel(Value: TVrBevel);
    procedure DoMouseDown(XPos, YPos: Integer);
    procedure BevelChanged(Sender: TObject);
    procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LButtonDown;
    procedure WMLButtonDblClk(var Message: TWMLButtonDblClk); message WM_LButtonDblClk;
    procedure WMMouseMove(var Message: TWMMouseMove); message WM_MouseMove;
    procedure WMLButtonUp(var Message: TWMLButtonUp); message WM_LButtonUp;
    procedure WMSetFocus(var Message: TWMSetFocus); message WM_SETFOCUS;
    procedure WMKillFocus(var Message: TWMKillFocus); message WM_KILLFOCUS;
    procedure WMGetDlgCode(var Message: TWMGetDlgCode); message WM_GETDLGCODE;
  protected
    procedure DoClick(Button: TVrButtonType);
    procedure KeyDown(var Key: Word; Shift: TShiftState); override;
    procedure KeyUp(var Key: Word; Shift: TShiftState); override;
    procedure LoadBitmaps;
    procedure CalcPaintParams;
    procedure GetButtonRect(Btn: TVrButtonType; var R: TRect);
    procedure DrawButton(Btn: TVrButtonType);
    procedure SetFocusedButton(Btn: TVrButtonType);
    procedure Paint; override;
    procedure Loaded; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure ButtonClick(Button: TVrButtonType); dynamic;
    function ButtonIndex(Button: TVrButtonType): Integer;
  published
    property Bevel: TVrBevel read FBevel write SetBevel;
    property Spacing: Integer read FSpacing write SetSpacing default 1;
    property FocusColor: TColor read FFocusColor write SetFocusColor default clBlue;
    property BorderColor: TColor read FBorderColor write SetBorderColor default clBlack;
    property VisibleButtons: TVrButtonSet read FVisibleButtons write SetVisibleButtons default DefVisibleButtons;
    property EnabledButtons: TVrButtonSet read FEnabledButtons write SetEnabledButtons default DefEnabledButtons;
    property Orientation: TVrOrientation read FOrientation write SetOrientation default voHorizontal;
    property Numeric: Boolean read FNumeric write SetNumeric default false;
    property OnButtonClick: TVrClickEvent read FOnButtonClick write FOnButtonClick;
    property Color;
{$IFDEF VER110}
    property Anchors;
    property Constraints;
{$ENDIF}
    property DragCursor;
{$IFDEF VER110}
    property DragKind;
{$ENDIF}
    property DragMode;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property TabOrder;
    property TabStop default True;
    property Visible;
{$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 VRNAVIGATOR.D32}


{ TVrNavigator }

constructor TVrNavigator.Create(AOwner: TComponent);
var
  I: TVrButtonType;
begin
  inherited Create(AOwner);
  ControlStyle := ControlStyle + [csOpaque] - [csSetCaption];
  Width := 340;
  Height := 25;
  TabStop := True;
  for I := Low(Buttons) to High(Buttons) do
  begin
    Buttons[I].Visible := True;
    Buttons[I].Enabled := True;
  end;
  FBevel := TVrBevel.Create;
  with FBevel do
  begin
    InnerSpace := 0;
    OnChange := BevelChanged;
  end;
  FFocusColor := clBlue;
  FBorderColor := clBlack;
  FSpacing := 1;
  FVisibleButtons := DefVisibleButtons;
  FEnabledButtons := DefEnabledButtons;
  FOrientation := voHorizontal;
  FNumeric := false;
  Bitmap := TBitmap.Create;
  FEnGlyphs := TBitmap.Create;
  FDiGlyphs := TBitmap.Create;
  LoadBitmaps;
end;

destructor TVrNavigator.Destroy;
begin
  Bitmap.Free;
  FEnGlyphs.Free;
  FDiGlyphs.Free;
  inherited Destroy;
end;

procedure TVrNavigator.Loaded;
var
  I: TVrButtonType;
begin
  inherited Loaded;
  for I := Low(Buttons) to High(Buttons) do
    if Buttons[I].Visible then
    begin
      FocusedButton := I;
      CurrentButton := I;
      Exit;
    end;
end;

procedure TVrNavigator.BevelChanged(Sender: TObject);
var
  R: TRect;
begin
  if not Loading then
  begin
    R := ClientRect;
    FBevel.GetVisibleArea(R);
    InflateRect(ViewPort, R.Left, R.Top);
    BoundsRect := Bounds(Left, Top, WidthOf(ViewPort),
      HeightOf(ViewPort));
  end;
  UpdateControlCanvas;
end;

procedure TVrNavigator.LoadBitmaps;
begin
  if FNumeric then
  begin
    FEnGlyphs.Handle := LoadBitmap(hInstance, 'EN_NUMERIC');
    FDiGlyphs.Handle := LoadBitmap(hInstance, 'DI_NUMERIC');
  end else
  begin
    FEnGlyphs.Handle := LoadBitmap(hInstance, 'EN_IMAGES');
    FDiGlyphs.Handle := LoadBitmap(hInstance, 'DI_IMAGES');
  end;
end;

procedure TVrNavigator.SetEnabledButtons(Value: TVrButtonSet);
var
  I: TVrButtonType;
begin
  FEnabledButtons := Value;
  for I := Low(Buttons) to High(Buttons) do
    Buttons[I].Enabled := I in FEnabledButtons;
  UpdateControlCanvas;
end;

procedure TVrNavigator.SetVisibleButtons(Value: TVrButtonSet);
var
  I: TVrButtonType;
begin
  FVisibleButtons := Value;
  for I := Low(Buttons) to High(Buttons) do
    Buttons[I].Visible := I in FVisibleButtons;
  UpdateControlCanvas;
end;

function TVrNavigator.VisibleButtonCount: Integer;
var
  I: TVrButtonType;
begin
  Result := 0;
  for I := Low(Buttons) to High(Buttons) do
    if Buttons[I].Visible then Inc(Result);
  if Result = 0 then Inc(Result);
end;

procedure TVrNavigator.SetSpacing(Value: Integer);
begin
  if FSpacing <> Value then
  begin
    FSpacing := Value;
    UpdateControlCanvas;
  end;
end;

procedure TVrNavigator.SetFocusColor(Value: TColor);
begin
  if FFocusColor <> Value then
  begin
    FFocusColor := Value;
    UpdateControlCanvas;
  end;
end;

procedure TVrNavigator.SetBorderColor(Value: TColor);
begin
  if FBorderColor <> Value then
  begin
    FBorderColor := Value;
    UpdateControlCanvas;
  end;
end;

procedure TVrNavigator.SetOrientation(Value: TVrOrientation);
var
  R: TRect;
  NewWidth: Integer;
  NewHeight: Integer;
begin
  if FOrientation <> Value then
  begin
    FOrientation := Value;
    if not Loading then
    begin
      NewWidth := 0;
      NewHeight := 0;
      case Value of
        voHorizontal:
          begin
            NewWidth := (VisibleButtonCount * (ButtonWidth + FSpacing));
            NewHeight := ButtonHeight;
          end;
        voVertical:
          begin
            NewWidth := ButtonWidth;
            NewHeight := (VisibleButtonCount * (ButtonHeight + FSpacing));
          end;
      end;
      R := Bounds(0, 0, NewWidth, NewHeight);
      InflateRect(R, ViewPort.Left, ViewPort.Top);
      BoundsRect := Bounds(Left, Top, WidthOf(R), HeightOf(R));
    end;
    UpdateControlCanvas;
  end;
end;

procedure TVrNavigator.SetBevel(Value: TVrBevel);
begin
  FBevel.Assign(Value);
end;

procedure TVrNavigator.SetNumeric(Value: Boolean);
begin
  if FNumeric <> Value then
  begin
    FNumeric := Value;
    LoadBitmaps;
    UpdateControlCanvas;
  end;
end;

function TVrNavigator.ButtonIndex(Button: TVrButtonType): Integer;
begin
  Result := Ord(Button) + 1;
end;

procedure TVrNavigator.DrawButton(Btn: TVrButtonType);
var
  IsDown: Boolean;
  GW, GH, BX, BY, hRes: Integer;
  Glyph: TBitmap;
  R: TRect;
  BtnRect: TRect;
  Colors: array[0..1] of TColor;
begin
  GetButtonRect(Btn, BtnRect);
  IsDown := Down and (Btn = CurrentButton);

  Bitmap.Width := ButtonWidth;
  Bitmap.Height := ButtonHeight;

  with Bitmap.Canvas do
  begin
    if Down then
    begin
      Colors[0] := clBtnFace;
      Colors[1] := clBtnHighlight;
    end
    else
    begin
      Colors[0] := clBtnHighlight;
      Colors[1] := clBtnShadow;
    end;

    hRes := ButtonHeight div 10;
    if hRes < 2 then HRes := 2;
    R := Bounds(0, 0, ButtonWidth, ButtonHeight);
    InflateRect(R, -2, -2);
    DrawGradient(Bitmap.Canvas, R, Colors[0], Colors[1], voVertical, hRes);

    if Buttons[Btn].Enabled then
      Glyph := FEnGlyphs else Glyph := FDiGlyphs;

    GH := Glyph.Height;
    GW := Glyph.Width div 10;
    BX := (ButtonWidth div 2) - (GW div 2);
    BY := (ButtonHeight div 2) - (GH div 2);
    if IsDown then
    begin
      Inc(BX);
      Inc(BY);
    end;
    Brush.Style := bsClear;
    BrushCopy(Bounds(BX, BY, GW, GH),
      Glyph, Bounds(ord(Btn) * GW, 0, GW, GH), clOlive);