midiin.pas

Delphi钢琴源码

  if FState = misOpen then
    raise EMidiInputError.Create('Change to ProductName while device was open')
  else
    if not (csLoading in ComponentState) then
    begin
      for testDeviceID := 0 to (midiInGetNumDevs - 1) do
      begin
        FError := midiInGetDevCaps(testDeviceID, @MidiInCaps, sizeof(TMidiInCaps));
        if Ferror <> MMSYSERR_NOERROR then
          raise EMidiInputError.Create(MidiIOErrorString(True, FError));
        testProductName := StrPas(MidiInCaps.szPname);
        if testProductName = NewProductName then
        begin
          FProductName := NewProductName;
          Break;
        end;
      end;
      if FProductName <> NewProductName then
        raise EMidiInputError.Create('MIDI Input Device ' + NewProductName + ' not installed ') else
        SetDeviceID(testDeviceID);
    end;
end;

procedure TMidiInput.PrepareHeaders;
{ Get the sysex buffers ready }
var
  ctr: Word;
  MyMidiHdr: TMyMidiHdr;
begin
  if (FSysexBufferCount > 0) and (FSysexBufferSize > 0) and (FMidiHandle <> 0) then
  begin
    Midihdrs := TList.Create;
    for ctr := 1 to FSysexBufferCount do
    begin
      { Initialize the header and allocate buffer memory }
      MyMidiHdr := TMyMidiHdr.Create(FSysexBufferSize);
      { Store the address of the MyMidiHdr object in the contained MIDIHDR structure
        so we can get back to the object when a pointer to the MIDIHDR is received }
      MyMidiHdr.hdrPointer^.dwUser := DWORD(MyMidiHdr);
      { Get MMSYSTEM's blessing for this header }
      FError := midiInPrepareHeader(FMidiHandle, MyMidiHdr.hdrPointer, sizeof(TMIDIHDR));
      if Ferror <> MMSYSERR_NOERROR then
        raise EMidiInputError.Create(MidiIOErrorString(True, FError));
      { Save it in our list }
      MidiHdrs.Add(MyMidiHdr);
    end;
  end;
end;

procedure TMidiInput.UnprepareHeaders;
{ Clean up from PrepareHeaders }
var
  ctr: Word;
begin
  if (MidiHdrs <> nil) then { will be Nil if 0 sysex buffers }
  begin
    for ctr := 0 to MidiHdrs.Count - 1 do
    begin
      FError := midiInUnprepareHeader(
        FMidiHandle,
        TMyMidiHdr(MidiHdrs.Items[ctr]).hdrPointer,
        sizeof(TMIDIHDR));
      if Ferror <> MMSYSERR_NOERROR then
        raise EMidiInputError.Create(MidiIOErrorString(True, FError));
      TMyMidiHdr(MidiHdrs.Items[ctr]).Free;
    end;
    MidiHdrs.Free;
    MidiHdrs := nil;
  end;
end;

procedure TMidiInput.AddBuffers;
{ Add sysex buffers, if required, to input device }
var
  ctr: Word;
begin
  if MidiHdrs <> nil then { will be Nil if 0 sysex buffers }
  begin
    if MidiHdrs.Count > 0 then
    begin
      for ctr := 0 to MidiHdrs.Count - 1 do
      begin
        FError := midiInAddBuffer(FMidiHandle,
          TMyMidiHdr(MidiHdrs.Items[ctr]).hdrPointer,
          sizeof(TMIDIHDR));
        if FError <> MMSYSERR_NOERROR then
          raise EMidiInputError.Create(MidiIOErrorString(True, FError));
      end;
    end;
  end;
end;

procedure TMidiInput.Open;
var
  hMem: THandle;
begin
  try
    { Create the buffer for the MIDI input messages }
    if (PBuffer = nil) then
      PBuffer := CircBufAlloc(FCapacity);
    { Create the control info for the DLL }
    if (PCtlInfo = nil) then
    begin
      PCtlInfo := GlobalSharedLockedAlloc(Sizeof(TMidiCtlInfo), hMem);
      PctlInfo^.hMem := hMem;
    end;
    PctlInfo^.pBuffer := PBuffer;
    Pctlinfo^.hWindow := Handle; { Control's window handle }
    PCtlInfo^.SysexOnly := FSysexOnly;
    FError := midiInOpen(
      @FMidiHandle,
      FDeviceId,
      DWORD(@midiHandler),
      DWORD(PCtlInfo),
      CALLBACK_FUNCTION);
    if (FError <> MMSYSERR_NOERROR) then
      { TODO: use CreateFmtHelp to add MIDI device name/ID to message }
      raise EMidiInputError.Create(MidiIOErrorString(True, FError));
    { Get sysex buffers ready }
    PrepareHeaders;
    { Add them to the input }
    AddBuffers;
    FState := misOpen;
  except
    if PBuffer <> nil then
    begin
      CircBufFree(PBuffer);
      PBuffer := nil;
    end;
    if PCtlInfo <> nil then
    begin
      GlobalSharedLockedFree(PCtlInfo^.hMem, PCtlInfo);
      PCtlInfo := nil;
    end;
  end;
end;

function TMidiInput.GetMidiEvent: TMyMidiEvent;
var
  thisItem: TMidiBufferItem;
begin
  if (FState = misOpen) and CircBufReadEvent(PBuffer, @thisItem) then
  begin
    Result := TMyMidiEvent.Create;
    with thisItem do
    begin
      Result.Time := Timestamp;
      if (Sysex = nil) then
      begin { Short message }
        Result.MidiMessage := LoByte(LoWord(Data));
        Result.Data1 := HiByte(LoWord(Data));
        Result.Data2 := LoByte(HiWord(Data));
        Result.Sysex := nil;
        Result.SysexLength := 0;
      end else { Long Sysex message }
      begin
        Result.MidiMessage := MIDI_BEGINSYSEX;
        Result.Data1 := 0;
        Result.Data2 := 0;
        Result.SysexLength := Sysex^.dwBytesRecorded;
        if Sysex^.dwBytesRecorded <> 0 then
        begin
          { Put a copy of the sysex buffer in the object }
          GetMem(Result.Sysex, Sysex^.dwBytesRecorded);
          StrMove(Result.Sysex, Sysex^.lpData, Sysex^.dwBytesRecorded);
        end;
        { Put the header back on the input buffer }
        FError := midiInPrepareHeader(FMidiHandle, Sysex, sizeof(TMIDIHDR));
        if Ferror = 0 then
          FError := midiInAddBuffer(FMidiHandle, Sysex, sizeof(TMIDIHDR));
        if Ferror <> MMSYSERR_NOERROR then
          raise EMidiInputError.Create(MidiIOErrorString(True, FError));
      end;
    end;
    CircbufRemoveEvent(PBuffer);
  end else
    { Device isn't open, return a nil event }
    Result := nil;
end;

function TMidiInput.GetEventCount: Word;
begin
  if FState = misOpen then
    Result := PBuffer^.EventCount
  else
    Result := 0;
end;

procedure TMidiInput.Close;
begin
  if FState = misOpen then
  begin
    FState := misClosed;
    { MidiInReset cancels any pending output }
    FError := MidiInReset(FMidiHandle);
    if Ferror <> MMSYSERR_NOERROR then
      raise EMidiInputError.Create(MidiIOErrorString(True, FError));
    { Remove sysex buffers from input device and free them }
    UnPrepareHeaders;
    { Close the device (finally!) }
    FError := MidiInClose(FMidiHandle);
    if Ferror <> MMSYSERR_NOERROR then
      raise EMidiInputError.Create(MidiIOErrorString(True, FError));
    FMidiHandle := 0;
    if (PBuffer <> nil) then
    begin
      CircBufFree(PBuffer);
      PBuffer := nil;
    end;
  end;
end;

procedure TMidiInput.Start;
begin
  if FState = misOpen then
  begin
    FError := MidiInStart(FMidiHandle);
    if Ferror <> MMSYSERR_NOERROR then
      raise EMidiInputError.Create(MidiIOErrorString(True, FError));
  end;
end;

procedure TMidiInput.Stop;
begin
  if FState = misOpen then
  begin
    FError := MidiInStop(FMidiHandle);
    if Ferror <> MMSYSERR_NOERROR then
      raise EMidiInputError.Create(MidiIOErrorString(True, FError));
  end;
end;

procedure TMidiInput.MidiInput(var Message: TMessage);
{ Triggered by incoming message from DLL.
  Note DLL has already put the message in the queue }
begin
  case Message.Msg of
    mim_data:
      { Trigger the user's MIDI input event }
      if Assigned(FOnMIDIInput) and (FState = misOpen) and (GetEventCount > 0) then
        FOnMIDIInput(Self);
    mim_Overflow:
      { input circular buffer overflow }
      if Assigned(FOnOverflow) and (FState = misOpen) then
        FOnOverflow(Self);
  end;
end;

procedure Register;
begin
  RegisterComponents('Piano Suite', [TMIDIInput]);
end;

end.