pianokeyboard.pas

Delphi钢琴源码

{
  TPianoKeyborad v1.0
    Integration TPianoButton and TPanel
    TPianoButton come from TShapeBut (torry.com)

  Zizii Wan, 20050626, ShangHai, China
}

unit PianoKeyboard;

interface

uses
  Windows, SysUtils, Messages, Classes, Graphics, Controls, StdCtrls, ExtCtrls,
  Forms, Buttons, ActnList, ImgList, Math;

type
  TNote = record
    iChar: Integer;
    iNote: Integer;
  end;

const
  CLastKey = 37;
  CMaxKey = 222;
  CLastGroup = 9;

const // Default values
  CColor = clBlack;
  CFontColor = clWhite;
  CPianoGroup = 5;
  CPianoOctave = 3;
  CAutoWidth = True;
  CShowGroup = True;
  CKeyBoardTop = 12;
  CKeyBoardLeft = 12;

var
  Groups: array[0..CLastGroup - 1] of string = (
    'C2-B2',
    'C1-B1',
    'C-B',
    'c-b',
    'c1-b1',
    'c2-b2',
    'c3-b3',
    'c4-b4',
    'c5-b5');
  Notes: array[0..CLastKey - 1] of TNote = (
    (iChar: 90; iNote: 0),
    (iChar: 83; iNote: 1),
    (iChar: 88; iNote: 2),
    (iChar: 68; iNote: 3),
    (iChar: 67; iNote: 4),
    (iChar: 86; iNote: 5),
    (iChar: 71; iNote: 6),
    (iChar: 66; iNote: 7),
    (iChar: 72; iNote: 8),
    (iChar: 78; iNote: 9),
    (iChar: 74; iNote: 10),
    (iChar: 77; iNote: 11),
    (iChar: 188; iNote: 12),
    (iChar: 76; iNote: 13),
    (iChar: 190; iNote: 14),
    (iChar: 186; iNote: 15),
    (iChar: 191; iNote: 16),
    (iChar: 81; iNote: 12),
    (iChar: 50; iNote: 13),
    (iChar: 87; iNote: 14),
    (iChar: 51; iNote: 15),
    (iChar: 69; iNote: 16),
    (iChar: 82; iNote: 17),
    (iChar: 53; iNote: 18),
    (iChar: 84; iNote: 19),
    (iChar: 54; iNote: 20),
    (iChar: 89; iNote: 21),
    (iChar: 55; iNote: 22),
    (iChar: 85; iNote: 23),
    (iChar: 73; iNote: 24),
    (iChar: 57; iNote: 25),
    (iChar: 79; iNote: 26),
    (iChar: 48; iNote: 27),
    (iChar: 80; iNote: 28),
    (iChar: 219; iNote: 29),
    (iChar: 187; iNote: 30),
    (iChar: 221; iNote: 31)
    );

type
  TBevelWidth = 0..2;
  TPairArray = array[0..1] of Integer;

  TPianoButton = class(TGraphicControl)
  private
    FAutoSize: Boolean;
    FState: TButtonState;
    FBevelWidth: TBevelWidth;
    FBitmap: TBitmap;
    FBitmapUp: TBitmap;
    FBitmapDown: TBitmap;
    FHitTestMask: TBitmap;
    FPrevCursorSaved: Boolean;
    FPrevCursor: TCursor;
    FPrevShowHintSaved: Boolean;
    FPrevShowHint: Boolean;
    FPreciseShowHint: Boolean;
    procedure AdjustBounds;
    procedure AdjustSize(var W, H: Integer);
    function BevelColor(const AState: TButtonState; const TopLeft: Boolean): TColor;
    procedure BitmapChanged(Sender: TObject);
    procedure Create3DBitmap(Source: TBitmap; const AState: TButtonState; Target: TBitmap);
    procedure SetAutoSize(Value: Boolean);
    procedure SetBitmap(Value: TBitmap);
    procedure SetBitmapDown(Value: TBitmap);
    procedure SetBitmapUp(Value: TBitmap);
    procedure CMDialogChar(var Message: TCMDialogChar); message CM_DIALOGCHAR;
    procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
    procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
    procedure CMSysColorChange(var Message: TMessage); message CM_SYSCOLORCHANGE;
    procedure CMHitTest(var Message: TCMHitTest); message CM_HITTEST;
    procedure SetBevelWidth(Value: TBevelWidth);
    procedure SetState(const Value: TButtonState);
  protected
    procedure DefineProperties(Filer: TFiler); override;
    procedure DrawButtonText(Canvas: TCanvas; const Caption: string; TextBounds: TRect; State: TButtonState); virtual;
    function GetPalette: HPALETTE; override;
    procedure Loaded; override;
    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 Paint; override;
    procedure ReadBitmapDownData(Stream: TStream); virtual;
    procedure ReadBitmapUpData(Stream: TStream); virtual;
    procedure WriteBitmapDownData(Stream: TStream); virtual;
    procedure WriteBitmapUpData(Stream: TStream); virtual;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Click; override;
    procedure Invalidate; override;
    function PtInMask(const X, Y: Integer): Boolean; virtual;
    procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;
    property BitmapUp: TBitmap read FBitmapUp;
    property BitmapDown: TBitmap read FBitmapDown;
    property State: TButtonState read FState write SetState;
  published
    property AutoSize: Boolean read FAutoSize write SetAutoSize default True;
    property BevelWidth: TBevelWidth read FBevelWidth write SetBevelWidth default 2;
    property Bitmap: TBitmap read FBitmap write SetBitmap;
    property Caption;
    property Enabled;
    property Font;
    property ParentFont;
    property ShowHint;
    property Visible;
    property OnClick;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
  end;

  TOnKeyboard = procedure(Event, data1, data2: Byte) of object;
  TPianoColor = (pcBlack, pcBlue, pcRed, pcGreen);

  { TPianoKeyboard }
  TPianoKeyboard = class(TCustomPanel)
  private
    FOwner: TWinControl;
    FPianoGroup: Integer;
    FPianoColor: TPianoColor;
    FPianoOctave: Byte;
    FGroupBox: TGroupBox;
    FPianoButton: array[0..11] of TPianoButton;
    FPianoBlackImgList: TImageList;
    FPianoWhiteImgList: TImageList;
    GrpsList, BtnsList, NotesList: TStringList;
    FKeyBoardLeft: Integer;
    FKeyBoardTop: Integer;
    FAutoWidth: Boolean;
    FShowGroup: Boolean;
    FOnKeyboard: TOnKeyboard;
    FGroupFontColor: TColor;
//    FOnPianoMouseDown: TMouseEvent;
//    FOnPianoMouseUp: TMouseEvent;
//    FOnPianoMouseMove: TMouseMoveEvent;
    procedure LoadBitmapFromResource;
    procedure InitPianoKeyboard;
    procedure BuildPianokeyBoard;
    procedure SetPianoColor(const Value: TPianoColor);
    procedure SetPianoOctave(const Value: Byte);
    procedure SetPianoGroup(const Value: Integer);
    procedure SetPianoGroupsMap;
    procedure SetKeyBoardLeft(const Value: Integer);
    procedure SetKeyBoardTop(const Value: Integer);
    procedure SetKeyBoardPos;
    procedure SetAutoWidth(const Value: Boolean);
    procedure SetShowGroup(const Value: Boolean);
    procedure ResetPianoButtons;
    procedure SetButtonColor(bFirst: Boolean; pcColor: TPianoColor; pbButton: TPianoButton);
    procedure SetButtonsColor(bFirst: Boolean; pcColor: TPianoColor);
    procedure SetGroupFontColor(const Value: TColor);
  protected
    procedure PianoMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
    procedure PianoMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
    procedure PianoMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure DoMidiEvent(Event, data1, data2: Byte; pcColor: TPianoColor);
    procedure DoPianoColor(iNote: Byte; pcColor: TPianoColor);
    procedure DoPianoShortCut(var Msg: TWMKey; var Handled: Boolean);
    procedure DoPianoKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
    procedure DoPianoKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
  published
    property GroupFontColor: TColor read FGroupFontColor write SetGroupFontColor;
    property PianoGroup: Integer read FPianoGroup write SetPianoGroup default CPianoGroup;
    property PianoColor: TPianoColor read FPianoColor write SetPianoColor default pcBlack;
    property PianoOctave: Byte read FPianoOctave write SetPianoOctave default CPianoOctave;
    property AutoWidth: Boolean read FAutoWidth write SetAutoWidth default CAutoWidth;
    property ShowGroup: Boolean read FShowGroup write SetShowGroup default CShowGroup;
    property KeyBoardTop: Integer read FKeyBoardTop write SetKeyBoardTop default CKeyBoardTop;
    property KeyBoardLeft: Integer read FKeyBoardLeft write SetKeyBoardLeft default CKeyBoardLeft;
    property OnKeyboard: TOnKeyboard read FOnKeyboard write FOnKeyboard;
//    property OnPianoMouseDown: TMouseEvent read FOnPianoMouseDown write FOnPianoMouseDown;
//    property OnPianoMouseMove: TMouseMoveEvent read FOnPianoMouseMove write FOnPianoMouseMove;
//    property OnPianoMouseUp: TMouseEvent read FOnPianoMouseUp write FOnPianoMouseUp;
    { inherited }
    property Anchors;
    property BevelInner;
    property BevelOuter;
    property BevelWidth;
    property Caption;
    property Color default CColor;
    property Enabled;
    property Font;
    property ParentFont;
    property PopupMenu;
    property ParentShowHint;
    property ShowHint;
    property Visible;
    property OnClick;
    property OnDblClick;
    property OnEnter;
    property OnExit;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnResize;
  end;

procedure Register;

implementation

{$R *.RES}

function MakeMask(ColorBmp: TBitmap; TransparentColor: TColor): TBitmap;
var
  R: TRect;
  OldBkColor: TColorRef;
begin
  Result := TBitmap.Create;
  try
    Result.Monochrome := True;
    Result.Width := ColorBmp.Width;
    Result.Height := ColorBmp.Height;
    OldBkColor := SetBkColor(ColorBmp.Canvas.Handle, ColorToRGB(TransparentColor));
    R := Rect(0, 0, ColorBmp.Width, ColorBmp.Height);
    Result.Canvas.CopyMode := cmSrcCopy;
    Result.Canvas.CopyRect(R, ColorBmp.Canvas, R);
    SetBkColor(ColorBmp.Canvas.Handle, OldBkColor);
  except
    Result.Free;
    raise;
  end;
end;

function MakeBorder(Source, NewSource: TBitmap; const OffsetPts: array of TPairArray;
  TransparentColor: TColor): TBitmap;
var
  I, W, H: Integer;
  R, NewR: TRect;
  SmallMask, BigMask, NewSourceMask: TBitmap;
begin
  Result := TBitmap.Create;
  try
    W := Source.Width;
    H := Source.Height;
    R := Rect(0, 0, W, H);
    Result.Monochrome := True;
    Result.Width := W;
    Result.Height := H;
    SmallMask := MakeMask(Source, TransparentColor);
    NewSourceMask := MakeMask(NewSource, TransparentColor);
    BigMask := MakeMask(NewSourceMask, TransparentColor);
    try
      BigMask.Canvas.CopyMode := cmSrcCopy;
      BigMask.Canvas.CopyRect(R, NewSourceMask.Canvas, R);
      for I := Low(OffsetPts) to High(OffsetPts) do
      begin
        if (OffsetPts[I, 0] = 0) and (OffsetPts[I, 1] = 0) then
          Break;
        NewR := R;
        OffsetRect(NewR, OffsetPts[I, 0], OffsetPts[I, 1]);
        BigMask.Canvas.CopyMode := cmSrcAnd;
        BigMask.Canvas.CopyRect(NewR, SmallMask.Canvas, R);
      end;
      BigMask.Canvas.CopyMode := cmSrcCopy;
      with Result do
      begin
        Canvas.CopyMode := cmSrcCopy;
        Canvas.CopyRect(R, NewSourceMask.Canvas, R);
        Canvas.CopyMode := $00DD0228;
        Canvas.CopyRect(R, BigMask.Canvas, R);
        Canvas.CopyMode := cmSrcCopy;
      end;
    finally
      SmallMask.Free;
      NewSourceMask.Free;
      BigMask.Free;
    end;
  except
    Result.Free;
    raise;
  end;
end;

{ TPianoButton }

constructor TPianoButton.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  SetBounds(0, 0, 80, 80);
  ControlStyle := [csCaptureMouse, csOpaque];
  FAutoSize := True;
  FBitmap := TBitmap.Create;
  FBitmap.OnChange := BitmapChanged;
  FBitmapUp := TBitmap.Create;
  FBitmapDown := TBitmap.Create;
  FHitTestMask := nil;
  ParentFont := True;
  FPreciseShowHint := True;
  FState := bsUp;
end;

destructor TPianoButton.Destroy;
begin
  FBitmap.Free;
  FBitmapUp.Free;
  FBitmapDown.Free;
  FHitTestMask.Free;
  inherited Destroy;
end;

procedure TPianoButton.Paint;
var
  W, H: Integer;
  Composite, Mask, Overlay, CurrentBmp: TBitmap;
  R, NewR: TRect;
begin
  if csDesigning in ComponentState then
    with Canvas do
    begin
      Pen.Style := psDash;
      Brush.Style := bsClear;
      Rectangle(0, 0, Width, Height);
    end;

  if (csDesigning in ComponentState) or
    (FState in [bsDisabled, bsExclusive]) then
    FState := bsUp;

  if (FState = bsUp) then
    CurrentBmp := FBitmapUp else
    CurrentBmp := FBitmapDown;

  if not CurrentBmp.Empty then
  begin
    W := Width;
    H := Height;
    R := ClientRect;
    NewR := R;

    Composite := TBitmap.Create;
    Overlay := TBitmap.Create;
    try
      with Composite do
      begin
        Width := W;
        Height := H;
        Canvas.CopyMode := cmSrcCopy;
        Canvas.CopyRect(R, Self.Canvas, R);
      end;
      with Overlay do
      begin
        Width := W;
        Height := H;
        Canvas.CopyMode := cmSrcCopy;
        Canvas.Brush.Color := FBitmap.TransparentColor;
        Canvas.FillRect(R);
        if FState = bsDown then
          OffsetRect(NewR, 1, 1);
        Canvas.CopyRect(NewR, CurrentBmp.Canvas, R);
      end;
      Mask := MakeMask(Overlay, FBitmap.TransparentColor);
      try
        Composite.Canvas.CopyMode := cmSrcAnd;
        Composite.Canvas.CopyRect(R, Mask.Canvas, R);

        Overlay.Canvas.CopyMode := $00220326;
        Overlay.Canvas.CopyRect(R, Mask.Canvas, R);

        Composite.Canvas.CopyMode := cmSrcPaint;
        Composite.Canvas.CopyRect(R, Overlay.Canvas, R);

        Canvas.CopyMode := cmSrcCopy;
        Canvas.CopyRect(R, Composite.Canvas, R);
      finally
        Mask.Free;
      end;
    finally
      Composite.Free;
      Overlay.Free;
    end;
  end;
  if Length(Caption) > 0 then
  begin
    Canvas.Font := Self.Font;
    R := CLIENTRECT;
    DrawButtonText(Canvas, Caption, R, FState);
  end;
end;

function TPianoButton.PtInMask(const X, Y: Integer): Boolean;
begin
  Result := True;
  if FHitTestMask <> nil then
    Result := (FHitTestMask.Canvas.Pixels[X, Y] = clBlack);
end;

procedure TPianoButton.MouseDown(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
var
  Clicked: Boolean;
begin
  inherited MouseDown(Button, Shift, X, Y);
  if (Button = mbLeft) and Enabled then
  begin
    Clicked := PtInMask(X, Y);
    if Clicked then
    begin
      FState := bsDown;
      Repaint;
    end;
  end;