cmpposdisplay.pas

Delphi的另一款钢琴软件

unit cmpPosDisplay;

interface

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

type
  TBoxClicked = procedure (sender : TObject; Button :TMouseButton; Shift : TShiftState; box : Integer) of object;
  TPosDisplay = class(TCustomControl)
  private
    fBar : Integer;
    fBeat : Integer;
    fTick : Integer;

    fSpacing : Integer;
    fBevelInner : TPanelBevel;
    fBevelOuter : TPanelBevel;
    fBorderStyle : TBorderStyle;
    fBackgroundColor : TColor;
    fAlignment : TAlignment;
    fBoxClicked : TBoxClicked;

    RectHeight, RectWidth, BevelWidth, TextY  : Integer;
    r : array [0..2] of TRect;
    oldCursor : TCursor;
    CaptureRect : Integer;
    Timer : TTimer;
    CaptureButton : TMouseButton;
    CaptureShift: TShiftState;

    procedure SetBar (value : Integer);
    procedure SetBeat (value : Integer);
    procedure SetTick (value : Integer);

    procedure SetSpacing (value : Integer);
    procedure SetBevelInner (value : TPanelBevel);
    procedure SetBevelOuter (value : TPanelBevel);
    procedure SetBorderStyle (value : TBorderStyle);
    procedure SetBackgroundColor (value : TColor);
    procedure SetAlignment (value : TAlignment);

    procedure UpdateDisplay;

    procedure FOnTimer (sender : TObject);

  protected
    procedure Paint; override;
    procedure WMMouseMove (var Msg : TWMMouseMove); message WM_MOUSEMOVE;

    procedure FnMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
    procedure FnMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);

  public
    constructor Create (AOwner : TComponent); override;
    procedure SetPosition (ABar, ABeat, ATick : Integer);
    { Public declarations }
  published
    property Bar : Integer read fBar write SetBar;
    property Beat : Integer read fBeat write SetBeat;
    property Tick : Integer read fTick write SetTick;
    property Spacing : Integer read fSpacing write SetSpacing;
    property BevelInner : TPanelBevel read fBevelInner write SetBevelInner;
    property BevelOuter : TPanelBevel read fBevelOuter write SetBevelOuter;
    property BorderStyle : TBorderStyle read fBorderStyle write SetBorderStyle;
    property BackgroundColor : TColor read fBackgroundColor write SetBackgroundColor;
    property Alignment : TAlignment read fAlignment write SetAlignment;
    property OnBoxClicked : TBoxClicked read fBoxClicked write fBoxClicked;

    property Font;
    property Color;
    property Align;
    property Ctl3D;

    property ParentColor;
    property ParentFont;
    property TabOrder;

    property OnDblClick;
  end;


implementation

{$R MIDICursors.res}

const
  PositionCursor = 5;

constructor TPosDisplay.Create (AOwner : TComponent);
begin
  inherited Create (AOwner);
  Width := 100;
  Height := 20;
  oldCursor := -32768;
  Screen.Cursors [positionCursor] := LoadCursor (HInstance, 'POSITIONCURSOR');
  fBackgroundColor := clBtnFace;
  OnMouseDown := FnMouseDown;
  OnMouseUp := FnMouseUp;
  Timer := TTimer.Create (self);
  Timer.OnTimer := FOnTimer;
  Timer.Enabled := False
end;

procedure TPosDisplay.SetSpacing (value : Integer);
begin
  if fSpacing <> value then
  begin
    fSpacing := value;
    Refresh
  end
end;

procedure TPosDisplay.SetBevelInner (value : TPanelBevel);
begin
  if fBevelInner <> value then
  begin
    fBevelInner := value;
    Refresh
  end
end;

procedure TPosDisplay.SetBevelOuter (value : TPanelBevel);
begin
  if fBevelOuter <> value then
  begin
    fBevelOuter := value;
    Refresh
  end
end;

procedure TPosDisplay.SetBorderStyle (value : TBorderStyle);
begin
  if fBorderStyle <> value then
  begin
    fBorderStyle := value;
    Refresh
  end
end;

procedure TPosDisplay.SetBackgroundColor (value : TColor);
begin
  if fBackgroundColor <> value then
  begin
    fBackgroundColor := value;
    Canvas.Brush.Color := value;
    Refresh
  end
end;

procedure TPosDisplay.SetAlignment (value : TAlignment);
begin
  if value <> fAlignment then
  begin
    fAlignment := value;
    Refresh
  end
end;

procedure TPosDisplay.SetPosition (ABar, ABeat, ATick : Integer);
begin
  fBar := ABar;
  fBeat := ABeat;
  fTick := ATick;
  UpdateDisplay;
end;

procedure TPosDisplay.SetBar (value : Integer);
begin
  if Value <> fBar then SetPosition (value, Beat, Tick);
end;

procedure TPosDisplay.SetBeat (value : Integer);
begin
  if Value <> fBeat then SetPosition (Bar, value, Tick);
end;

procedure TPosDisplay.SetTick (value : Integer);
begin
  if Value <> fTick then SetPosition (Bar, Beat, value);
end;

procedure TPosDisplay.UpdateDisplay;

  procedure DrawXText (n, value : Integer);
  var
    w, x : Integer;
    s : string;
  begin
    s := IntToStr (value);
    if Alignment = taLeftJustify then
      x := r [n].Left + 1
    else
    begin
      w := Canvas.TextWidth (s);
        if Alignment = taRightJustify then
          x := r [n].Right - w - 1
        else
          x := r [n].Left + (RectWidth - w) div 2
    end;
    Canvas.FillRect (r [n]);
    Canvas.TextOut (x, TextY - 1, s);
//    Canvas.TextRect (r [n], x, TextY, s);
  end;

begin
  DrawXText (0, fBar + 1);
  DrawXText (1, fBeat + 1);
  DrawXText (2, fTick);
end;

procedure TPosDisplay.Paint;

  procedure DrawBevel (x, y, w, h : Integer; tp : TPanelBevel);
  begin
    case tp of
      bvRaised :
        with Canvas do
        begin
          Pen.Color := clBtnHighlight;
          MoveTo (x, y + h);
          LineTo (x, y);
          LineTo (x + w + 1, y);

          Pen.Color := clBtnShadow;
          MoveTo (x + w, y + 1);
          LineTo (x + w, y + h);
          LineTo (x, y + h);
        end;
      bvLowered :
        with Canvas do
        begin
          Pen.Color := clBtnShadow;
          MoveTo (x, y + h);
          LineTo (x, y);
          LineTo (x + w + 1, y);

          Pen.Color := clBtnHighlight;
          MoveTo (x + w, y + 1);
          LineTo (x + w, y + h);
          LineTo (x, y + h);
        end;
    end;
  end;

begin
  Canvas.Pen.Width := 1;
  Canvas.Font := Font;
  Canvas.Brush.Color := fBackgroundColor;
  if BevelInner <> bvNone then
    BevelWidth := 2
  else
    if BevelOuter <> bvNone then
      BevelWidth := 1
    else
      BevelWidth := 0;

  RectWidth := (ClientWidth - 2 * Spacing) div 3 - 1;
  RectHeight := ClientHeight - 1;

  DrawBevel (0, 0, RectWidth, RectHeight, BevelOuter);
  DrawBevel (1, 1, RectWidth - 2, RectHeight - 2, BevelInner);

  DrawBevel (RectWidth + Spacing + 1, 0, RectWidth, RectHeight, BevelOuter);
  DrawBevel (RectWidth + Spacing + 2, 1, RectWidth - 2, RectHeight - 2, BevelInner);

  DrawBevel ((RectWidth + Spacing + 1) * 2, 0, RectWidth, RectHeight, BevelOuter);
  DrawBevel ((RectWidth + Spacing + 1) * 2 + 1, 1, RectWidth - 2, RectHeight - 2, BevelInner);

  Dec (RectWidth, BevelWidth * 2);
  Dec (RectHeight, BevelWidth * 2);
  Inc (RectWidth);
  Inc (RectHeight);

  r [0].left := BevelWidth;
  r [0].right := r [0].left + RectWidth;
  r [0].Top := BevelWidth;
  r [0].Bottom := r [0].Top + RectHeight;

  r [1].Top := r [0].Top;
  r [1].Bottom := r [0].Bottom;
  r [2].Top := r [0].Top;
  r [2].Bottom := r [0].Bottom;

  r [1].left := r [0].right + Spacing + BevelWidth * 2;
  r [1].right := r [1].left + RectWidth;

  r [2].left := r [1].right + Spacing + BevelWidth * 2;
  r [2].right := r [2].left + RectWidth;

  TextY := r [0].top + (RectHeight - Canvas.TextHeight ('0')) div 2 + 1;
  UpdateDisplay;
end;


procedure TPosDisplay.WMMouseMove (var Msg : TWMMouseMove);
var box  :Integer;

  procedure CheckCursor (cross : boolean);
  begin
    if cross then
    begin
      if oldCursor = -32768 then
      begin
        oldCursor := Cursor;
        Cursor := positionCursor
      end
    end
    else
      if oldCursor <> -32768 then
      begin
        Cursor := oldCursor;
        oldCursor := -32768
      end
  end;

begin
  CaptureRect := -1;
  for box := 0 to 2 do
    if PtInRect (r [box], SmallPointToPoint (Msg.pos)) then
    begin
      CheckCursor (True);
      CaptureRect := box
    end;
  if CaptureRect = -1 then
  begin
    CheckCursor (False);
    Timer.Enabled := False
  end
end;

procedure TPosDisplay.FnMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  if (CaptureRect <> -1) and Assigned (fBoxClicked) then
  begin
    CaptureButton := Button;
    CaptureShift := Shift;
    Timer.Interval := 300;
    Timer.Enabled := True;
    fBoxClicked (sender, button, shift, CaptureRect)
  end
end;

procedure TPosDisplay.FnMouseUp (Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  Timer.Enabled := False;
end;

procedure TPosDisplay.FOnTimer (sender : TObject);
var t : Integer;
begin
  fBoxClicked (sender, captureButton, captureShift, CaptureRect);
  t := Timer.Interval - 100;
  if t < 50 then t := 50;
  Timer.Interval := t
end;

end.