cmpmidiinput.pas

Delphi的另一款钢琴软件

unit cmpMidiInput;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, mmsystem,
  cmpMidiOutput, cmpMidiData, unitMidiTrackStream,unitMidiGlobals, cmpMidiIterator;

type
  TPortRange = 0..7;
  TPortArray = array [TPortRange] of boolean;
  TOnStepData = procedure (const data : TEventData) of object;
  TOnSysexData = procedure (data : PChar; len : word) of object;
  TMidiInput = class(TComponent)
  private
    fTakes : TList;
    fSyncPosition : TMidiPosition;
    fPortArray : TPortArray;
    fMidiInHandle : array [TPortRange] of HMIDIIN;
    fMidiEchoPort : TMidiOutputPort;
    fRecording : boolean;
    fRecordBuffer : TMidiTrackStream;
    fRecordEventNo : Integer;
    fRecordStartTime : Integer;
    fStepMode : boolean;
    fOnStepData : TOnStepData;
    fChannelOverride : Integer;
    fOnSysexData: TOnSysexData;
    fSysexHeaders : TList;
    fClosing : array [TPortRange] of  boolean;
    fOnSystemMessage: TOnStepData;

    function GetOpenPorts (idx : TPortRange) : boolean;
    procedure SetOpenPorts (idx : TPortRange; value : boolean);

    procedure SetEchoPort (value : Integer);
    function GetEchoPort : Integer;

    procedure SetChannelOverride (value : Integer);

    procedure OpenPort (idx : TPortRange);
    procedure ClosePort (idx : TPortRange);

    function GetTakeCount : Integer;
    function GetTake (index : Integer) : TMidiTrackStream;
    function CalcTakeName : string;
    procedure AddSysexBuffer (idx : TPortRange);
    procedure TidySysexBuffers;

  protected
    procedure MidiInCallback (handle : HMIDIOUT; uMsg : UINT; dw1, dw2 : DWORD);

  public
    constructor Create (AOwner : TComponent); override;
    destructor Destroy; override;
    property OpenPorts [idx : TPortRange] : boolean read GetOpenPorts write SetOpenPorts;
    procedure SetRecording (value : boolean; syncData : TMidiData);
    property BytesRecorded : Integer read fRecordEventNo;
    property RecordStartTime : Integer read fRecordStartTime write fRecordStartTime;
    property Recording : boolean read fRecording;
    property RecordBuffer : TMidiTrackStream read fRecordBuffer;
    property TakeCount : Integer read GetTakeCount;
    property Take [index : Integer] : TMidiTrackStream read GetTake;
    procedure DeleteTake (index : Integer);

  published
    property EchoPort : Integer read GetEchoPort write SetEchoPort;
    property OnStepData : TOnStepData read fOnStepData write fOnStepData;
    property OnSysexData : TOnSysexData read fOnSysexData write fOnSysexData;
    property OnSystemMessage : TOnStepData read fOnSystemMessage Write fOnSystemMessage;
    property StepMode : boolean read fStepMode write fStepMode;
    property ChannelOverride : Integer read fChannelOverride write SetChannelOverride;
  end;

implementation

procedure MidiInCallback (handle : HMIDIOUT; uMsg : UINT; dwUser, dw1, dw2 : DWORD); stdcall;
var
  midiInput : TMidiInput absolute dwUser;
begin
  midiInput.MidiInCallback (handle, uMsg, dw1, dw2);
end;

constructor TMidiInput.Create (AOwner : TComponent);
begin
  inherited Create (AOwner);
  fSysexHeaders := TList.Create;
  fTakes := TList.Create;
  fChannelOverride := -1
end;

destructor TMidiInput.Destroy;
var
  idx : TPortRange;
  i : Integer;
begin
  for idx := Low (TPortRange) to High (TPortRange) do
    ClosePort (idx);

  while fSysexHeaders.Count > 0 do
    TidySysexBuffers;

  SetRecording (False, Nil);

  for i := 0 to fTakes.Count - 1 do
    TObject (fTakes [i]).Free;
  fTakes.Free;

  inherited;
end;

function TMidiInput.GetOpenPorts (idx : TPortRange) : boolean;
begin
  result := fPortArray [idx];
end;

procedure TMidiInput.SetOpenPorts (idx : TPortRange; value : boolean);
begin
  if value <> fPortArray [idx] then
  begin
    case value of
      True : OpenPort (idx);
      False : ClosePort (idx)
    end
  end
end;

procedure TMidiInput.SetEchoPort (value : Integer);
begin
  if Assigned (fMidiEchoPort) then
  begin
    if value = fMidiEchoPort.PortId then exit;
    fMidiEchoPort.Free;
    fMidiEchoPort := Nil
  end;

  if value <> -2 then
  begin
    fMidiEchoPort := TMidiOutputPort.Create (self);
    fMidiEchoPort.PortID := value;
    fMidiEchoPort.Active := True
  end
end;

function TMidiInput.GetEchoPort : Integer;
begin
  if Assigned (fMidiEchoPort) then
    result := fMidiEchoPort.PortID
  else
   result := -2
end;

procedure TMidiInput.SetChannelOverride (value : Integer);
begin
  if value <> fChannelOverride then
  begin
    fChannelOverride := value;
    if Assigned (fMidiEchoPort) then
      fMidiEchoPort.AllNotesOff
  end
end;

procedure TMidiInput.OpenPort (idx : TPortRange);
begin
  if not fPortArray [idx] then
  begin
    fClosing [idx] := False;
    if midiInOpen (@fMidiInHandle [idx], idx, DWORD (@cmpMidiInput.MidiInCallback), DWORD (self), CALLBACK_FUNCTION) = MMSYSERR_NOERROR then
    begin
      AddSysexBuffer (idx);
      AddSysexBuffer (idx);
      midiInStart (fMidiInHandle [idx]);
      fPortArray [idx] := True
    end
  end
end;

procedure TMidiInput.ClosePort (idx : TPortRange);
begin
  if fPortArray [idx] then
  begin
    fClosing [idx] := True;
    midiInReset (fMidiInHandle [idx]);
    midiInClose (fMidiInHandle [idx]);
    fPortArray [idx] := False
  end
end;

procedure TMidiInput.MidiInCallback (handle : HMIDIOUT; uMsg : UINT; dw1, dw2 : DWORD);
var
  midiEvent : TEventData absolute dw1;
  pos : Integer;
  hdr : PMidiHdr;
begin
  case uMsg of
    MIM_DATA :
      begin
        if Assigned (fMidiEchoPort) then
        begin
          if fChannelOverride <> -1 then
          begin
            if midiEvent.status < $f0 then
              midiEvent.Status := (midiEvent.status and $f0) + fChannelOverride;
          end;
          fMidiEchoPort.OutEvent (midiEvent);
        end;
        if not (midiEvent.Status in [$f8, $fe]) then
        begin
          if fStepMode and Assigned (fOnStepData) then
            fOnStepData (midiEvent)
          else
          if fRecording  then
          begin
            with fSyncPosition do
            begin
              CalcPositionFromTime (dw2 + DWord (RecordStartTime));
              pos := Position
            end;
            fRecordBuffer.InsertEvent (pos, midiEvent, 0)
          end
        end
        else
          if Assigned (fOnSystemMessage) then
            fOnSystemMessage (midiEvent)
      end;

    MIM_LONGDATA :
      begin
        hdr := PMidiHdr (dw1);
        if Assigned (fOnSysexData) and (hdr^.dwBytesRecorded > 0) then
          OnSysexData (hdr^.lpData, hdr^.dwBytesRecorded);
        TidySysexBuffers;
      end;

    MIM_LONGERROR :
      begin
        TidySysexBuffers
      end
  end
end;

procedure TMidiInput.SetRecording (value : boolean; syncData : TMidiData);
var
  idx : Integer;
begin
  if value <> fRecording then
    case value of
      False :
        begin
          fSyncPosition.Free;
          fRecording := False;
          fTakes.Add (fRecordBuffer);
          fRecordBuffer := Nil
        end;

      True :
      begin
        fSyncPosition := TMidiPosition.Create (Nil);
        fSyncPosition.MidiData := syncData;

        fRecordBuffer := TMidiTrackStream.Create (100000);
        fRecordBuffer.Init;
        fRecordBuffer.TrackName := CalcTakeName;
        fRecordBuffer.TempPort := EchoPort;

        for idx := Low (TPortRange) to High (TPortRange) do
          if fPortArray [idx] then
          begin
            midiInStop (fMidiInHandle [idx]);
            midiInStart (fMidiInHandle [idx])
          end;

        fRecordEventNo := 0;
        fRecording := True;
      end
    end
end;

function TMidiInput.GetTakeCount : Integer;
begin
  result := fTakes.Count;
end;

function TMidiInput.GetTake (index : Integer) : TMidiTrackStream;
begin
  result := TMidiTrackStream (fTakes [index]);
end;

procedure TMidiInput.DeleteTake (index : Integer);
begin
  TObject (fTakes [index]).Free;
  fTakes.Delete (index)
end;

function TMidiInput.CalcTakeName : string;
var
  i, h, x : Integer;
  s : string;
begin
  h := 0;
  for i := 0 to TakeCount - 1 do
  begin
    s := Take [i].TrackName;
    if Copy (s, 1, 5) = 'Take ' then
    begin
      x := StrToInt (Copy (s, 6, MaxInt));
      if x > h then h := x
    end
  end;
  Inc (h);
  result := 'Take ' + IntToStr (h)
end;

procedure TMidiInput.AddSysexBuffer (idx : TPortRange);
var
  hdr : PMidiHdr;
begin
  TidySysexBuffers;
  GetMem (hdr, sizeof (TMidiHdr));
  ZeroMemory (hdr, SizeOf (TMidiHdr));
  GetMem (hdr^.lpData, 65536);
  hdr^.dwBufferLength := 65536;
  hdr^.dwUser := idx;
  midiInPrepareHeader (fMidiInHandle [idx], hdr, sizeof (hdr^));
  midiInAddBuffer (fMidiInHandle [idx], hdr, sizeof (hdr^));
  fSysexHeaders.Add (hdr);
end;

procedure TMidiInput.TidySysexBuffers;
var
  i : Integer;
  hdr : PMidiHdr;
  idx : Integer;
begin
  i := 0;
  while i < fSysexHeaders.Count do
  begin
    hdr := PMidiHdr (fSysexHeaders [i]);
    if (hdr^.dwFlags and MHDR_DONE) = MHDR_DONE then
    begin
      idx := hdr^.dwUser;
      MidiInUnprepareHeader (fMidiInHandle [idx], hdr, sizeof (hdr^));

      if fClosing [idx] then
      begin
        FreeMem (hdr^.lpData);
        fSysexHeaders.Delete (i);
      end
      else
      begin
        hdr^.dwOffset := 0;
        hdr^.dwBytesRecorded := 0;
        MidiInPrepareHeader (fMidiInHandle [idx], hdr, sizeof (hdr^));
        MidiInAddBuffer (fMidiInHandle [idx], hdr, sizeof (hdr^));
      end
    end
    else
      Inc (i)
  end
end;

end.