www.pudn.com > d4psp31.zip > cmpMidiInput.pas, change:1998-07-09,size:7416b


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; 
  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; 
 
    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; 
 
  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 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); 
  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); 
 
  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 
    if midiInOpen (@fMidiInHandle [idx], idx, DWORD (@cmpMidiInput.MidiInCallback), DWORD (self), CALLBACK_FUNCTION) = MMSYSERR_NOERROR then 
    begin 
      midiInStart (fMidiInHandle [idx]); 
      fPortArray [idx] := True 
    end 
  end 
end; 
 
procedure TMidiInput.ClosePort (idx : TPortRange); 
begin 
  if fPortArray [idx] then 
  begin 
    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; 
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 
          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 
  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; 
 
end.