cmpkeyboard.pas

Delphi的另一款钢琴软件

unit cmpKeyboard;

interface

uses Controls, Classes, Graphics;

type
  TKeyboardOrientation = (kbHorizontal, kbVertical);
  TKeyboardNoteEvent = procedure (Sender : TObject; note, velocity : Integer) of object;

  TKeys = class (TGraphicControl)
    private
      FOrientation : TKeyboardOrientation;
      FNoteWidth : Integer;
      FBaseOctave : Integer;
      FBlackBrush : TBrush;
      FWhiteBrush : TBrush;
      FPen : TPen;
      FVelocityMode : boolean;
      FOnNoteOn : TKeyboardNoteEvent;
      FOnNoteOff : TKeyboardNoteEvent;
      noteMap : set of 0..127;
      currentNote : Integer;

      procedure SetNoteWidth (width : Integer);
      procedure SetBaseOctave (octave : Integer);
      procedure SetOrientation (orient: TKeyboardOrientation);
      procedure SetBlackBrush (value : TBrush);
      procedure SetWhiteBrush (value : TBrush);
      procedure SetPen (value : TPen);
      procedure StyleChanged (Sender : TObject);
      procedure FnMouseDown (Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
      procedure FnMouseUp (Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
      procedure FnMouseMove (Sender: TObject; Shift: TShiftState; X, Y: Integer);
      procedure GetSize (var w, l, blackw, blackl : Integer);
      procedure PaintHorizontal;
      procedure PaintVertical;

    published
      property Orientation : TKeyboardOrientation read FOrientation write SetOrientation default kbHorizontal;
      property NoteWidth : Integer read FNoteWidth write SetNoteWidth default 10;
      property BaseOctave : Integer read FBaseOctave write SetBaseOctave default 3;
      property Height default 50;
      property Width default 200;
      property BlackBrush : TBrush read FBlackBrush write SetBlackBrush;
      property WhiteBrush : TBrush read FWhiteBrush write SetWhiteBrush;
      property Pen : TPen read FPen write SetPen;
      property VelocityMode : boolean read FVelocityMode write FVelocityMode default True;

      property OnNoteOn : TKeyboardNoteEvent read FOnNoteOn write FOnNoteOn;
      property OnNoteOff : TKeyboardNoteEvent read FOnNoteOff write FOnNoteOff;

    protected
      procedure Paint; override;
      procedure InvertNote (note : Integer);

    public
      constructor Create (AOwner : TComponent); override;
      destructor Destroy; override;
      procedure DecodeNote (note : Integer; var octave, key : Integer; var sharp : boolean);
      function NoteAt (x, y : Integer; var velocity : Integer) : Integer;
      procedure PressNote (note, velocity : Integer; GenerateEvent : boolean);
      procedure ReleaseNote (note, aftertouch : Integer; GenerateEvent : boolean);
      procedure AllNotesOff (GenerateEvent : boolean);
  end;

  TMIDIChannel = 1..16;
  TMIDIKeys = class (TKeys)

    private
      FMIDIDevice : Integer;
      FMIDIChannel : TMIDIChannel;
      FMIDIPortName : string;
      FMIDIPortOk : Boolean;
      FMIDIPort : Integer;

      procedure SetMIDIDevice (value : Integer);
      procedure NoteOn (Sender : TObject; note, velocity : Integer);
      procedure NoteOff (Sender : TObject; note, velocity : Integer);

    published
      property MIDIDevice : Integer read FMIDIDevice write SetMIDIDevice nodefault;
      property MIDIChannel : TMIDIChannel read FMIDIChannel write FMIDIChannel default 1;

      property MIDIPortName : string read FMIDIPortName;
      property MIDIPortOk : boolean read FMIDIPortOk;

    public
      constructor Create (AOwner : TComponent); override;
      destructor Destroy; override;
      property MIDIPort : Integer read FMIDIPort;

    protected
      procedure SelectMIDIPort;
    end;

implementation

uses WinProcs, WinTypes, SysUtils, MMSystem;

const
  blackOffsets : array [0..6] of Integer = (-1, 1, 0, -1, 0, 1, 0);

constructor TKeys.Create (AOwner : TComponent);
begin
  inherited Create (AOwner);
  ControlStyle := ControlStyle + [csOpaque];

  FBlackBrush := TBrush.Create;
  FWhiteBrush := TBrush.Create;
  FPen := TPen.Create;

  FBlackBrush.OnChange := StyleChanged;
  FWhiteBrush.OnChange := StyleChanged;
  FPen.OnChange := StyleChanged;

  Width := 200;
  Height := 50;
  FNoteWidth := 10;
  FOrientation := kbHorizontal;
  FBaseOctave := 3;
  FVelocityMode := True;

  BlackBrush.Color := clBlack;
  WhiteBrush.Color := clWhite;
  Pen.Color := clBlack;

  noteMap := [];
  currentNote := -1;

  OnMouseDown := fnMouseDown;
  OnMouseUp := fnMouseUp;
  OnMouseMove := fnMouseMove;
  OnNoteOn := Nil;
  OnNoteOff := Nil;

end;

destructor TKeys.Destroy;
begin
  FWhiteBrush.Free;
  FBlackBrush.Free;
  FPen.Free;
  inherited Destroy
end;

procedure TKeys.DecodeNote (note : Integer; var octave, key : Integer; var sharp : boolean);
var k : Integer;
begin
  octave := note div 12;
  k := note mod 12;
  if k >= 5 then Inc (k);
  key := k shr 1;
  sharp := odd (k)
end;

procedure TKeys.GetSize (var w, l, blackw, blackl: Integer);
begin
  if Orientation = kbHorizontal then
  begin
    w := width;
    l := height
  end
  else
  begin
    w := height;
    l := width
  end;
  blackl := l * 3 div 5;
  blackw := NoteWidth * 3 div 5;
  if not odd (blackw) then Inc (blackw);
end;

procedure TKeys.PaintHorizontal;
var
  p, x, keyNo : Integer;
  w, l, BlackLength, BlackWidth, BlackWidth1 : Integer;
begin
  GetSize (w, l, BlackWidth, BlackLength);
  BlackWidth1 := BlackWidth shr 1;

  p := NoteWidth;
  keyNo := 0;
  with canvas do while p < w do
  begin
    MoveTo (p, 0);
    LineTo (p, l);
    if keyNo in [0, 1, 3, 4, 5] then
    begin
      x := p - BlackWidth1 + blackOffsets [keyNo];
      Rectangle (x, 0, x + BlackWidth, BlackLength);
    end;
    Inc (p, NoteWidth);
    keyNo := (keyNo + 1) mod 7
  end
end;

procedure TKeys.PaintVertical;
var
  p, y, keyNo : Integer;
  w, l, BlackLength, BlackWidth, BlackWidth1 : Integer;
begin
  GetSize (w, l, BlackWidth, BlackLength);
  BlackWidth1 := BlackWidth shr 1;

  p := w - NoteWidth - 1;
  keyNo := 0;
  with canvas do while p > 0 do
  begin
    MoveTo (0, p);
    LineTo (l, p);
    if keyNo in [0, 1, 3, 4, 5] then
    begin
      y := p - BlackWidth1 - blackOffsets [keyNo];
      Rectangle (0, y, BlackLength, y + BlackWidth);
    end;
    Dec (p, NoteWidth);
    keyNo := (keyNo + 1) mod 7
  end
end;

procedure TKeys.Paint;
begin
  with Canvas do
  begin
    Brush := FWhiteBrush;
    Pen := FPen;
    Rectangle (0, 0, Width, Height);
    Brush := FBLackBrush;
    if Orientation = kbHorizontal then PaintHorizontal else PaintVertical
  end
end;

procedure TKeys.InvertNote (note : Integer);
var
  Octave, KeyNo, KeyNo1, noteDist : Integer;
  sharp : boolean;
  w, l, BlackLength, BlackWidth, BlackWidth1, BlackDist, BlackDist1 : Integer;
begin
  Dec (note, 12 * baseOctave);
  GetSize (w, l, BlackWidth, BlackLength);
  BlackWidth1 := BlackWidth shr 1;
  DecodeNote (note, Octave, KeyNo, sharp);
  noteDist := (KeyNo + Octave * 7) * NoteWidth;
  if KeyNo = 0 then KeyNo1 := 6 else KeyNo1 := KeyNo - 1;
  with Canvas do if Orientation = kbHorizontal then
  begin
    blackDist := noteDist + noteWidth - BlackWidth1 + BlackOffsets [keyNo];
    blackDist1 := noteDist - BlackWidth1 + BlackOffsets [keyNo1];
    if sharp then
      PatBlt (Handle, blackDist + 1, 1, BlackWidth - 2, BlackLength - 2, DSTINVERT)
    else
    begin
      PatBlt (Handle, noteDist + 2, BlackLength + 1, NoteWidth - 3, l - BlackLength - 3, DSTINVERT);
      case KeyNo of
        0, 3 : PatBlt (Handle, noteDist + 2, 2,
                               blackDist - noteDist - 3,
                               BlackLength - 1, DSTINVERT);
        1, 4, 5 : PatBlt (Handle, BlackDist1 + BlackWidth + 1, 2,
                                  BlackDist - BlackDist1 - BlackWidth - 2,
                                  BlackLength - 1, DSTINVERT);
        2, 6 : PatBlt (Handle, BlackDist1 + BlackWidth + 1, 2,
                               NoteDist + NoteWidth - BlackDist1 - BlackWidth - 2,
                               BlackLength - 1, DSTINVERT);
      end
    end
  end
  else
  begin
    noteDist := Height - noteDist - noteWidth;
    blackDist := noteDist + BlackWidth1 - BlackOffsets [keyNo] - BlackWidth;
    blackDist1 := noteDist + NoteWidth + BlackWidth1 - BlackOffsets [keyNo1] - BlackWidth;
    if sharp then
      PatBlt (Handle, 1, blackDist + 1, BlackLength - 2, BlackWidth - 2, DSTINVERT)
    else
    begin
      PatBlt (Handle, BlackLength + 1, noteDist + 1, l - BlackLength - 3, NoteWidth - 3, DSTINVERT);
      case KeyNo of
        0, 3 : PatBlt (Handle, 2, blackDist + BlackWidth + 1,