cmpkeyboard.pas

Delphi的另一款钢琴软件

                               BlackLength - 1,
                               noteWidth - BlackWidth1 - 4, DSTINVERT);
        1, 4, 5 : PatBlt (Handle, 2, BlackDist + BlackWidth + 1,
                                  BlackLength - 1,
                                  BlackDist1 - BlackDist - BlackWidth - 2, DSTINVERT);
        2, 6 : PatBlt (Handle, 2, noteDist + 1,
                                  BlackLength - 1,
                                  blackDist1 - noteDist - 2, DSTINVERT);
      end
    end
  end
end;

procedure TKeys.SetNoteWidth (Width : Integer);
begin
  if FNoteWidth <> width then
  begin
    FNoteWidth  := Width;
    Invalidate
  end
end;

procedure TKeys.SetOrientation (Orient : TKeyboardOrientation);
begin
  if FOrientation <> Orient then
  begin
    FOrientation := Orient;
    Invalidate
  end
end;

procedure TKeys.SetBaseOctave (octave : Integer);
begin
  if octave <> FBaseOctave then
  begin
    FBaseOctave := octave;
    Repaint
  end
end;

procedure TKeys.SetBlackBrush (value : TBrush);
begin
  FBlackBrush.Assign (value)
end;

procedure TKeys.SetWhiteBrush (value : TBrush);
begin
  FWhiteBrush.Assign (value)
end;

procedure TKeys.SetPen (value : TPen);
begin
  FPen.Assign (value)
end;

procedure TKeys.StyleChanged (Sender : TObject);
begin
  Invalidate
end;

function TKeys.NoteAt (x, y : Integer; var velocity : Integer) : Integer;
var
  KeyNo, KeyNo1, KeyPos, Octave, noteNo, noteDist : Integer;
  sharp : boolean;
  w, l, BlackLength, BlackWidth, BlackWidth1 : Integer;
begin
  GetSize (w, l, BlackWidth, BlackLength);
  BlackWidth1 := BlackWidth shr 1;

  if Orientation = kbHorizontal then
  begin
    KeyPos := x;
    noteDist := y
  end
  else
  begin
    KeyPos := w - y - 1;
    noteDist := x
  end;

  KeyNo := KeyPos div noteWidth;
  KeyPos := KeyPos mod noteWidth;
  Octave := KeyNo div 7;
  KeyNo := KeyNo mod 7;
  if KeyNo = 0 then KeyNo1 := 6 else KeyNo1 := KeyNo - 1;
  sharp := False;
  if noteDist < BlackLength then
    if keyPos >= NoteWidth - BlackWidth1 + blackOffsets [KeyNo] then
      sharp := KeyNo in [0, 1, 3, 4, 5]
    else
      if keyPos < BlackWidth - BlackWidth1 + blackOffsets [KeyNo1] then
      begin
        sharp := KeyNo in [1, 2, 4, 5, 6];
        if sharp then KeyNo := KeyNo1
      end;

  noteNo := KeyNo * 2;
  if noteNo >= 6 then Dec (noteNo);
  if sharp then
  begin
    Inc (noteNo);
    l := BlackLength;
  end;
  if FVelocityMode then
    velocity := noteDist * 127 div l
  else
    velocity := 127;
  noteAt := noteNo + (Octave + BaseOctave) * 12;
end;

procedure TKeys.PressNote (note, velocity : Integer; GenerateEvent : boolean);
begin
  if not (note in noteMap) then
  begin
    InvertNote (note);
    noteMap := noteMap + [note]
  end;
  if GenerateEvent and Assigned (FOnNoteOn) then OnNoteOn (Self, note, velocity);
end;

procedure TKeys.ReleaseNote (note, aftertouch : Integer; GenerateEvent : boolean);
begin
  if note in noteMap then
  begin
    InvertNote (note);
    noteMap := noteMap - [note]
  end;
  if GenerateEvent and Assigned (FOnNoteOff) then OnNoteOff (Self, note, 0);
end;

procedure TKeys.AllNotesOff (GenerateEvent : boolean);
var i : Integer;
begin
  for i := 0 to 127 do
    if i in noteMap then
      ReleaseNote (i, 0, GenerateEvent)
end;

procedure TKeys.FnMouseDown (Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var n, velocity : Integer;
begin
  SetCaptureControl (self);
  if Button = mbLeft then
  begin
    n := NoteAt (x, y, velocity);
    if (n >= 0) and (n < 128) then
    begin
      currentNote := n;
      PressNote (currentNote, velocity, True)
    end
  end
end;

procedure TKeys.FnMouseUp (Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  SetCaptureControl (Nil);
  ReleaseNote (currentNote, 0, True)
end;

procedure TKeys.FnMouseMove (Sender: TObject; Shift: TShiftState; X, Y: Integer);
var Note, velocity : Integer;
begin
  if (ssLeft in Shift) and PtInRect (Rect (0, 0, width - 1, height - 1), Point (x, y)) then
  begin
    note := NoteAt (x, y, velocity);
    if (note >= 0) and (note < 128) and (note <> CurrentNote) then
    begin
      ReleaseNote (CurrentNote, 0, True);
      CurrentNote := note;
      PressNote (CurrentNote, velocity, True)
    end
  end
end;

constructor TMIDIKeys.Create (AOwner : TComponent);
begin
  inherited Create (AOwner);
  OnNoteOn := NoteOn;
  OnNoteOff := NoteOff;

  FMIDIDevice := -1;
  FMIDIPortName := 'Microsoft MIDI Mapper';
  FMIDIChannel := 1;
end;

destructor TMIDIKeys.Destroy;
begin
  if midiPort <> 0 then
  begin
    midiOutReset (midiPort);
    midiOutClose (midiPort);
  end;
  inherited Destroy
end;

procedure TMIDIKeys.SelectMIDIPort;
var
  rv, noDevs : Word;
begin
  if midiPort <> 0 then
  begin
    midiOutReset (midiPort);
    midiOutClose (midiPort);
    FMIDIPort := 0;
  end;

  FMIDIportOk := False;

  noDevs := midiOutGetNumDevs;
  if FMIDIDevice < noDevs then
  begin
    rv := midiOutOpen (@FMIDIPort, FMIDIDevice, 0, 0, 0);
    if rv = 0 then FMIDIPortOk := True;
  end
end;

procedure TMIDIKeys.SetMIDIDevice (value : Integer);
var
  noDevs : Integer;
  devCaps : TMidiOutCaps;
begin
  if value <> FMIDIDevice then
  begin
    if midiPort <> 0 then
    begin
      midiOutReset (midiPort);
      midiOutClose (midiPort);
      FMIDIPort := 0
    end;

    FMIDIDevice := value;
    noDevs := midiOutGetNumDevs;
    if FMIDIDevice < noDevs then
    begin
      midiOutGetDevCaps (FMIDIDevice, @devCaps, sizeof (devCaps));
      FMIDIPortName := StrPas (devCaps.szPName);
    end
    else FMIDIPortName := '';
  end
end;

procedure TMIDIKeys.NoteOn (Sender : TObject; note, velocity : Integer);
var
  data : record case boolean of
    True  : (b1, b2, b3, b4 : byte);
    False : (l : LongInt);
  end;
begin
  if midiPort = 0 then SelectMIDIPort;
  if FMIDIPortOk then with data do
  begin
    b1 := $90 + FMIDIChannel - 1;
    b2 := note;
    b3 := velocity;
    b4 := 0;
    midiOutShortMsg (midiPort, l);
  end;
end;

procedure TMIDIKeys.NoteOff (Sender : TObject; note, velocity : Integer);
var
  data : record case boolean of
    True  : (b1, b2, b3, b4 : byte);
    False : (l : LongInt);
  end;
begin
  if FMIDIPortOk then with data do
  begin
    b1 := $80 + FMIDIChannel - 1;
    b2 := note;
    b3 := velocity;
    b4 := 0;
    midiOutShortMsg (midiPort, l);
  end;
end;

end.