www.pudn.com > d4psp31.zip > cmpPosDisplay.pas, change:1998-06-22,size:9239b


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 PowerSequencerCursors.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.