midiin.pas

Delphi钢琴源码

unit MidiIn;

interface

uses
  Classes, SysUtils, WinTypes, Messages, WinProcs, MMSystem, MidiCommon;

type
  MidiInputState = (misOpen, misClosed, misCreating, misDestroying);
  EMidiInputError = class(Exception);

  TMidiInput = class(TComponent)
  private
    Handle: THandle; { Window handle used for callback notification }
    FDeviceID: Word; { MIDI device ID }
    FMIDIHandle: HMIDIIn; { Handle to input device }
    FState: MidiInputState; { Current device state }
    FError: Word;
    FSysexOnly: Boolean;
    { Stuff from MIDIINCAPS }
    FDriverVersion: Version;
    FProductName: string;
    FMID: Word; { Manufacturer ID }
    FPID: Word; { Product ID }
    { Queue }
    FCapacity: Word; { Buffer capacity }
    PBuffer: PCircularBuffer; { Low-level MIDI input buffer created by Open method }
    FNumdevs: Word; { Number of input devices on system }
    { Events }
    FOnMIDIInput: TNotifyEvent; { MIDI Input arrived }
    FOnOverflow: TNotifyEvent; { Input buffer overflow }
    { TODO: Some sort of error handling event for MIM_ERROR }
    { Sysex }
    FSysexBufferSize: Word;
    FSysexBufferCount: Word;
    MidiHdrs: Tlist;
    PCtlInfo: PMidiCtlInfo; { Pointer to control info for DLL }
  protected
    procedure Prepareheaders;
    procedure UnprepareHeaders;
    procedure AddBuffers;
    procedure SetDeviceID(DeviceID: Word);
    procedure SetProductName(NewProductName: string);
    function GetEventCount: Word;
    procedure SetSysexBufferSize(BufferSize: Word);
    procedure SetSysexBufferCount(BufferCount: Word);
    procedure SetSysexOnly(bSysexOnly: Boolean);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    property MIDIHandle: HMIDIIn read FMIDIHandle;
    property DriverVersion: Version read FDriverVersion;
    property MID: Word read FMID; { Manufacturer ID }
    property PID: Word read FPID; { Product ID }
    property Numdevs: Word read FNumdevs;
    property MessageCount: Word read GetEventCount;
    { TODO: property to select which incoming messages get filtered out }
    procedure Open;
    procedure Close;
    procedure Start;
    procedure Stop;
    { Get first message in input queue }
    function GetMidiEvent: TMyMidiEvent;
    procedure MidiInput(var Message: TMessage);
    { Some functions to decode and classify incoming messages would be good }
  published
    { TODO: Property editor with dropdown list of product names }
    property ProductName: string read FProductName write SetProductName;
    property DeviceID: Word read FDeviceID write SetDeviceID default 0;
    property Capacity: Word read FCapacity write FCapacity default 1024;
    property Error: Word read FError;
    property SysexBufferSize: Word read FSysexBufferSize write SetSysexBufferSize default 10000;
    property SysexBufferCount: Word read FSysexBufferCount write SetSysexBufferCount default 16;
    property SysexOnly: Boolean read FSysexOnly write SetSysexOnly default False;
 { Events }
    property OnMidiInput: TNotifyEvent read FOnMidiInput write FOnMidiInput;
    property OnOverflow: TNotifyEvent read FOnOverflow write FOnOverflow;
  end;

procedure Register;

implementation

uses Graphics, Controls, Forms, Dialogs;

function CircbufAlloc(Capacity: Word): PCircularBuffer;
var
  NewCircularBuffer: PCircularBuffer;
  NewMIDIBuffer: PMidiBufferItem;
  hMem: HGLOBAL;
begin
  { TODO: Validate circbuf size, <64K }
  NewCircularBuffer := GlobalSharedLockedAlloc(Sizeof(TCircularBuffer), hMem);
  if (NewCircularBuffer <> nil) then
  begin
    NewCircularBuffer^.RecordHandle := hMem;
    NewMIDIBuffer := GlobalSharedLockedAlloc(Capacity * Sizeof(TMidiBufferItem), hMem);
    if (NewMIDIBuffer = nil) then
    begin
      { TODO: Exception here? }
      GlobalSharedLockedFree(NewCircularBuffer^.RecordHandle, NewCircularBuffer);
      NewCircularBuffer := nil;
    end else
    begin
      NewCircularBuffer^.pStart := NewMidiBuffer;
      { Point to item at end of buffer }
      NewCircularBuffer^.pEnd := NewMidiBuffer;
      Inc(NewCircularBuffer^.pEnd, Capacity);
      { Start off the get and put pointers in the same position.
        These will get out of sync as the interrupts start rolling in }
      NewCircularBuffer^.pNextPut := NewMidiBuffer;
      NewCircularBuffer^.pNextGet := NewMidiBuffer;
      NewCircularBuffer^.Error := 0;
      NewCircularBuffer^.Capacity := Capacity;
      NewCircularBuffer^.EventCount := 0;
    end;
  end;
  CircbufAlloc := NewCircularBuffer;
end;

procedure CircbufFree(pBuffer: PCircularBuffer);
begin
  if (pBuffer <> nil) then
  begin
    GlobalSharedLockedFree(pBuffer^.BufferHandle, pBuffer^.pStart);
    GlobalSharedLockedFree(pBuffer^.RecordHandle, pBuffer);
  end;
end;

function CircbufReadEvent(PBuffer: PCircularBuffer; PEvent: PMidiBufferItem): Boolean;
{ Reads first event in queue without removing it, False if no events in queue }
var
  PCurrentEvent: PMidiBufferItem;
begin
  if (PBuffer^.EventCount <= 0) then
    CircbufReadEvent := False else
  begin
    PCurrentEvent := PBuffer^.PNextget;
    { Copy the object from the "tail" of the buffer to the caller's object }
    PEvent^.Timestamp := PCurrentEvent^.Timestamp;
    PEvent^.Data := PCurrentEvent^.Data;
    PEvent^.Sysex := PCurrentEvent^.Sysex;
    CircbufReadEvent := True;
  end;
end;

function CircbufRemoveEvent(PBuffer: PCircularBuffer): Boolean;
{ Remove current event from the queue }
begin
  if (PBuffer^.EventCount > 0) then
  begin
    Dec(Pbuffer^.EventCount);
    { Advance the buffer pointer, with wrap }
    Inc(Pbuffer^.PNextGet);
    if (PBuffer^.PNextGet = PBuffer^.PEnd) then
      PBuffer^.PNextGet := PBuffer^.PStart;
    CircbufRemoveEvent := True;
  end else
    CircbufRemoveEvent := False;
end;

constructor TMidiInput.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FState := misCreating;
  FSysexOnly := False;
  FNumDevs := midiInGetNumDevs;
  MidiHdrs := nil;
  { Set defaults }
  if (FNumDevs > 0) then
    SetDeviceID(0);
  FCapacity := 1024;
  FSysexBufferSize := 4096;
  FSysexBufferCount := 16;
  { Create the window for callback notification }
  if not (csDesigning in ComponentState) then
  begin
    Handle := AllocateHwnd(MidiInput);
  end;
  FState := misClosed;
end;

destructor TMidiInput.Destroy;
{ Close the device if it's open }
begin
  if (FMidiHandle <> 0) then
  begin
    Close;
    FMidiHandle := 0;
  end;
  if (PCtlInfo <> nil) then
    GlobalSharedLockedFree(PCtlinfo^.hMem, PCtlInfo);
  DeallocateHwnd(Handle);
  inherited Destroy;
end;

procedure TMidiInput.SetSysexBufferSize(BufferSize: Word);
{ Set the sysex buffer size, fail if device is already open }
begin
  if FState = misOpen then
    raise EMidiInputError.Create('Change to SysexBufferSize while device was open')
  else
    { TODO: Validate the sysex buffer size. Is this necessary for WIN32? }
    FSysexBufferSize := BufferSize;
end;

procedure TMidiInput.SetSysexBuffercount(Buffercount: Word);
{ Set the sysex buffer count, fail if device is already open }
begin
  if FState = misOpen then
    raise EMidiInputError.Create('Change to SysexBuffercount while device was open')
  else
    { TODO: Validate the sysex buffer count }
    FSysexBuffercount := Buffercount;
end;

procedure TMidiInput.SetSysexOnly(bSysexOnly: Boolean);
{ Set the Sysex Only flag to eliminate unwanted short MIDI input messages }
begin
  FSysexOnly := bSysexOnly;
  { Update the interrupt handler's copy of this property }
  if PCtlInfo <> nil then
    PCtlInfo^.SysexOnly := bSysexOnly;
end;

procedure TMidiInput.SetDeviceID(DeviceID: Word);
{ Set the Device ID to select a new MIDI input device
  Note: If no MIDI devices are installed, throws an 'Invalid Device ID' exception }
var
  MidiInCaps: TMidiInCaps;
begin
  if FState = misOpen then
    raise EMidiInputError.Create('Change to DeviceID while device was open')
  else
    if (DeviceID >= midiInGetNumDevs) then
      raise EMidiInputError.Create('Invalid device ID') else
    begin
      FDeviceID := DeviceID;
      { Set the name and other MIDIINCAPS properties to match the ID }
      FError := midiInGetDevCaps(DeviceID, @MidiInCaps, sizeof(TMidiInCaps));
      if Ferror <> MMSYSERR_NOERROR then
        raise EMidiInputError.Create(MidiIOErrorString(True, FError));
      FProductName := StrPas(MidiInCaps.szPname);
      FDriverVersion := MidiInCaps.vDriverVersion;
      FMID := MidiInCaps.wMID;
      FPID := MidiInCaps.wPID;
    end;
end;

procedure TMidiInput.SetProductName(NewProductName: string);
{ Set the product name and put the matching input device number in FDeviceID }
var
  MidiInCaps: TMidiInCaps;
  testDeviceID: Word;
  testProductName: string;
begin