{ $Header: /MidiComp/MidiIn.pas 2 10/06/97 7:33 Davec $ } { Written by David Churcher <dchurcher@cix.compulink.co.uk>, released to the public domain. } unit MidiIn; { Properties: DeviceID: Windows numeric device ID for the MIDI input device. Between 0 and NumDevs-1. Read-only while device is open, exception when changed while open MIDIHandle: The input handle to the MIDI device. 0 when device is not open Read-only, runtime-only MessageCount: Number of input messages waiting in input buffer Capacity: Number of messages input buffer can hold Defaults to 1024 Limited to (64K/event size) Read-only when device is open (exception when changed while open) SysexBufferSize: Size in bytes of each sysex buffer Defaults to 10K Minimum 0K (no buffers), Maximum 64K-1 SysexBufferCount: Number of sysex buffers Defaults to 16 Minimum 0 (no buffers), Maximum (avail mem/SysexBufferSize) Check where these buffers are allocated? SysexOnly: True to ignore all non-sysex input events. May be changed while device is open. Handy for patch editors where you have lots of short MIDI events on the wire which you are always going to ignore anyway. DriverVersion: Version number of MIDI device driver. High-order byte is major version, low-order byte is minor version. ProductName: Name of product (e.g. 'MPU 401 In') MID and PID: Manufacturer ID and Product ID, see "Manufacturer and Product IDs" in MMSYSTEM.HLP for list of possible values. Methods: GetMidiEvent: Read Midi event at the head of the FIFO input buffer. Returns a TMyMidiEvent object containing MIDI message data, timestamp, and sysex data if applicable. This method automatically removes the event from the input buffer. It makes a copy of the received sysex buffer and puts the buffer back on the input device. The TMyMidiEvent object must be freed by calling MyMidiEvent.Free. Open: Opens device. Note no input will appear until you call the Start method. Close: Closes device. Any pending system exclusive output will be cancelled. Start: Starts receiving MIDI input. Stop: Stops receiving MIDI input. Events: OnMidiInput: Called when MIDI input data arrives. Use the GetMidiEvent to get the MIDI input data. OnOverflow: Called if the MIDI input buffer overflows. The caller must clear the buffer before any more MIDI input can be received. Notes: Buffering: Uses a circular buffer, separate pointers for next location to fill and next location to empty because a MIDI input interrupt may be adding data to the buffer while the buffer is being read. Buffer pointers wrap around from end to start of buffer automatically. If buffer overflows then the OnBufferOverflow event is triggered and no further input will be received until the buffer is emptied by calls to GetMidiEvent. Sysex buffers: There are (SysexBufferCount) buffers on the input device. When sysex events arrive these buffers are removed from the input device and added to the circular buffer by the interrupt handler in the DLL. When the sysex events are removed from the circular buffer by the GetMidiEvent method the buffers are put back on the input. If all the buffers are used up there will be no more sysex input until at least one sysex event is removed from the input buffer. In other words if you're expecting lots of sysex input you need to set the SysexBufferCount property high enough so that you won't run out of input buffers before you get a chance to read them with GetMidiEvent. If the synth sends a block of sysex that's longer than SysexBufferSize it will be received as separate events. TODO: Component derived from this one that handles >64K sysex blocks cleanly and can stream them to disk. Midi Time Code (MTC) and Active Sensing: The DLL is currently hardcoded to filter these short events out, so that we don't spend all our time processing them. TODO: implement a filter property to select the events that will be filtered out. } interface {$IFDEF FPC} {$MODE Delphi} {$H+} // use long strings {$ENDIF} uses Classes, SysUtils, Messages, Windows, MMSystem, {$IFDEF FPC} WinAllocation, {$ENDIF} MidiDefs, MidiType, MidiCons, CircBuf, DelphiMcb; 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: MMVERSION; 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); function MidiInErrorString(WError: word): string; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; property MIDIHandle: HMIDIIn read FMIDIHandle; property DriverVersion: MMVERSION 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 Controls, Graphics; (* Not used in Delphi 3 { This is the callback procedure in the external DLL. It's used when midiInOpen is called by the Open method. There are special requirements and restrictions for this callback procedure (see midiInOpen in MMSYSTEM.HLP) so it's impractical to make it an object method } {$IFDEF MSWINDOWS} function midiHandler( hMidiIn: HMidiIn; wMsg: UINT; dwInstance: dword; dwParam1: dword; dwParam2: dword): boolean; stdcall; external 'DELMID32.DLL'; {$ENDIF} *) {-------------------------------------------------------------------} 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; {-------------------------------------------------------------------} { Close the device if it's open } destructor TMidiInput.Destroy; begin if FMidiHandle <> 0 then begin Close; FMidiHandle := 0; end; if PCtlInfo <> nil then GlobalSharedLockedFree(PCtlinfo^.hMem, PCtlInfo); DeallocateHwnd(Handle); inherited Destroy; end; {-------------------------------------------------------------------} { Convert the numeric return code from an MMSYSTEM function to a string using midiInGetErrorText. TODO: These errors aren't very helpful (e.g. "an invalid parameter was passed to a system function") so sort out some proper error strings. } function TMidiInput.MidiInErrorString(WError: word): string; var errorDesc: Pchar; begin errorDesc := nil; try errorDesc := StrAlloc(MAXERRORLENGTH); if midiInGetErrorText(WError, errorDesc, MAXERRORLENGTH) = 0 then result := StrPas(errorDesc) else result := 'Specified error number is out of range'; finally if errorDesc <> nil then StrDispose(errorDesc); end; end; {-------------------------------------------------------------------} { Set the sysex buffer size, fail if device is already open } procedure TMidiInput.SetSysexBufferSize(BufferSize: word); 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; {-------------------------------------------------------------------} { Set the sysex buffer count, fail if device is already open } procedure TMidiInput.SetSysexBuffercount(Buffercount: word); 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; {-------------------------------------------------------------------} { Set the Sysex Only flag to eliminate unwanted short MIDI input messages } procedure TMidiInput.SetSysexOnly(bSysexOnly: boolean); begin FSysexOnly := bSysexOnly; { Update the interrupt handler's copy of this property } if PCtlInfo <> nil then PCtlInfo^.SysexOnly := bSysexOnly; end; {-------------------------------------------------------------------} { Set the Device ID to select a new MIDI input device Note: If no MIDI devices are installed, throws an 'Invalid Device ID' exception } procedure TMidiInput.SetDeviceID(DeviceID: word); 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(MidiInErrorString(FError)); FProductName := StrPas(MidiInCaps.szPname); FDriverVersion := MidiInCaps.vDriverVersion; FMID := MidiInCaps.wMID; FPID := MidiInCaps.wPID; end; end; {-------------------------------------------------------------------} { Set the product name and put the matching input device number in FDeviceID. This is handy if you want to save a configured input/output device by device name instead of device number, because device numbers may change if users add or remove MIDI devices. Exception if input device with matching name not found, or if input device is open } procedure TMidiInput.SetProductName(NewProductName: string); var MidiInCaps: TMidiInCaps; testDeviceID: word; testProductName: string; begin if FState = misOpen then raise EMidiInputError.Create('Change to ProductName while device was open') else { Don't set the name if the component is reading properties because the saved Productname will be from the machine the application was compiled on, which may not be the same for the corresponding DeviceID on the user's machine. The FProductname property will still be set by SetDeviceID } if not (csLoading in ComponentState) then begin begin for testDeviceID := 0 to (midiInGetNumDevs - 1) do begin FError := midiInGetDevCaps(testDeviceID, @MidiInCaps, sizeof(TMidiInCaps)); if Ferror <> MMSYSERR_NOERROR then raise EMidiInputError.Create(MidiInErrorString(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; end; {-------------------------------------------------------------------} { Get the sysex buffers ready } procedure TMidiInput.PrepareHeaders; 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. E.g. see TMidiOutput.Output method } 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(MidiInErrorString(FError)); { Save it in our list } MidiHdrs.Add(MyMidiHdr); end; end; end; {-------------------------------------------------------------------} { Clean up from PrepareHeaders } procedure TMidiInput.UnprepareHeaders; 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(MidiInErrorString(FError)); TMyMidiHdr(MidiHdrs.Items[ctr]).Free; end; MidiHdrs.Free; MidiHdrs := nil; end; end; {-------------------------------------------------------------------} { Add sysex buffers, if required, to input device } procedure TMidiInput.AddBuffers; 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(MidiInErrorString(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(MidiInErrorString(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(MidiInErrorString(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. Note that midiInReset causes an MIM_LONGDATA callback for each sysex buffer on the input, so the callback function and Midi input buffer should still be viable at this stage. All the resulting MIM_LONGDATA callbacks will be completed by the time MidiInReset returns, though. } FError := MidiInReset(FMidiHandle); if Ferror <> MMSYSERR_NOERROR then raise EMidiInputError.Create(MidiInErrorString(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(MidiInErrorString(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(MidiInErrorString(FError)); end; end; {-------------------------------------------------------------------} procedure TMidiInput.Stop; begin if FState = misOpen then begin FError := MidiInStop(FMidiHandle); if Ferror <> MMSYSERR_NOERROR then raise EMidiInputError.Create(MidiInErrorString(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 they've specified one and we're not in the process of closing the device. The check for GetEventCount > 0 prevents unnecessary event calls where the user has already cleared all the events from the input buffer using a GetMidiEvent loop in the OnMidiInput event handler } 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('Synth', [TMIDIInput]); end; end.