{ $Header: /MidiComp/MidiOut.pas 2 10/06/97 7:33 Davec $ } { Written by David Churcher <dchurcher@cix.compulink.co.uk>, released to the public domain. } { Thanks very much to Fred Kohler for the Technology code. } unit MidiOut; { MIDI Output component. Properties: DeviceID: Windows numeric device ID for the MIDI output device. Between 0 and (midioutGetNumDevs-1), or MIDI_MAPPER (-1). Special value MIDI_MAPPER specifies output to the Windows MIDI mapper Read-only while device is open, exception if changed while open MIDIHandle: The output handle to the MIDI device. 0 when device is not open Read-only, runtime-only ProductName: Name of the output device product that corresponds to the DeviceID property (e.g. 'MPU 401 out'). You can write to this while the device is closed to select a particular output device by name (the DeviceID property will change to match). Exception if this property is changed while the device is open. Numdevs: Number of MIDI output devices installed on the system. This is the value returned by midiOutGetNumDevs. It's included for completeness. Technology: Type of technology used by the MIDI device. You can set this property to one of the values listed for OutportTech (below) and the component will find an appropriate MIDI device. For example: MidiOutput.Technology := opt_FMSynth; will set MidiInput.DeviceID to the MIDI device ID of the FM synth, if one is installed. If no such device is available an exception is raised, see MidiOutput.SetTechnology. See the MIDIOUTCAPS entry in MMSYSTEM.HLP for descriptions of the following properties: DriverVersion Voices Notes ChannelMask Support Error: The error code for the last MMSYSTEM error. See the MMSYSERR_ entries in MMSYSTEM.INT for possible values. Methods: Open: Open MIDI device specified by DeviceID property for output Close: Close device PutMidiEvent(Event:TMyMidiEvent): Output a note or sysex message to the device. This method takes a TMyMidiEvent object and transmits it. Notes: 1. If the object contains a sysex event the OnMidiOutput event will be triggered when the sysex transmission is complete. 2. You can queue up multiple blocks of system exclusive data for transmission by chucking them at this method; they will be transmitted as quickly as the device can manage. 3. This method will not free the TMyMidiEvent object, the caller must do that. Any sysex data in the TMyMidiEvent is copied before transmission so you can free the TMyMidiEvent immediately after calling PutMidiEvent, even if output has not yet finished. PutShort(MidiMessage: Byte; Data1: Byte; Data2: Byte): Output a short MIDI message. Handy when you can't be bothered to build a TMyMidiEvent. If the message you're sending doesn't use Data1 or Data2, set them to 0. PutLong(TheSysex: Pointer; msgLength: Word): Output sysex data. SysexPointer: Pointer to sysex data to send msgLength: Length of sysex data. This is handy when you don't have a TMyMidiEvent. SetVolume(Left: Word, Right: Word): Set the volume of the left and right channels on the output device (only on internal devices?). 0xFFFF is maximum volume. If the device doesn't support separate left/right volume control, the value of the Left parameter will be used. Check the Support property to see whether the device supports volume control. See also other notes on volume control under midiOutSetVolume() in MMSYSTEM.HLP. Events: OnMidiOutput: Procedure called when output of a system exclusive block is completed. Notes: I haven't implemented any methods for midiOutCachePatches and midiOutCacheDrumpatches, mainly 'cause I don't have any way of testing them. Does anyone really use these? } interface {$IFDEF FPC} {$MODE Delphi} {$H+} // use AnsiString {$ENDIF} uses SysUtils, Windows, Messages, Classes, MMSystem, UCommon, Circbuf, MidiType, MidiDefs, Delphmcb; {$IFDEF FPC} type TmidioutCaps = MIDIOUTCAPS; {$ENDIF} type midioutputState = (mosOpen, mosClosed); EmidioutputError = class(Exception); { These are the equivalent of constants prefixed with mod_ as defined in MMSystem. See SetTechnology } OutPortTech = ( opt_None, { none } opt_MidiPort, { output port } opt_Synth, { generic internal synth } opt_SQSynth, { square wave internal synth } opt_FMSynth, { FM internal synth } opt_Mapper); { MIDI mapper } TechNameMap = array[OutPortTech] of string[18]; const TechName: TechNameMap = ( 'None', 'MIDI Port', 'Generic Synth', 'Square Wave Synth', 'FM Synth', 'MIDI Mapper'); {-------------------------------------------------------------------} type TMidiOutput = class(TComponent) protected Handle: THandle; { Window handle used for callback notification } FDeviceID: Cardinal; { MIDI device ID } FMIDIHandle: Hmidiout; { Handle to output device } FState: midioutputState; { Current device state } PCtlInfo: PMidiCtlInfo; { Pointer to control info for DLL } PBuffer: PCircularBuffer; { Output queue for PutTimedEvent, set by Open } FError: Word; { Last MMSYSTEM error } { Stuff from midioutCAPS } FDriverVersion: MMVERSION; { Driver version from midioutGetDevCaps } FProductName: string; { product name } FTechnology: OutPortTech; { Type of MIDI output device } FVoices: Word; { Number of voices (internal synth) } FNotes: Word; { Number of notes (internal synth) } FChannelMask: Word; { Bit set for each MIDI channels that the device responds to (internal synth) } FSupport: DWORD; { Technology supported (volume control, patch caching etc. } FNumdevs: Word; { Number of MIDI output devices on system } FOnMIDIOutput: TNotifyEvent; { Sysex output finished } procedure MidiOutput(var Message: TMessage); procedure SetDeviceID(DeviceID: Cardinal); procedure SetProductName(NewProductName: string); procedure SetTechnology(NewTechnology: OutPortTech); function midioutErrorString(WError: Word): string; public { Properties } property MIDIHandle: Hmidiout read FMIDIHandle; property DriverVersion: MMVERSION { Driver version from midioutGetDevCaps } read FDriverVersion; property Technology: OutPortTech { Type of MIDI output device } read FTechnology write SetTechnology default opt_Synth; property Voices: Word { Number of voices (internal synth) } read FVoices; property Notes: Word { Number of notes (internal synth) } read FNotes; property ChannelMask: Word { Bit set for each MIDI channels that the } read FChannelMask; { device responds to (internal synth) } property Support: DWORD { Technology supported (volume control, } read FSupport; { patch caching etc. } property Error: Word read FError; property Numdevs: Word read FNumdevs; { Methods } function Open: Boolean; virtual; function Close: Boolean; virtual; procedure PutMidiEvent(theEvent: TMyMidiEvent); virtual; procedure PutShort(MidiMessage: Byte; Data1: Byte; Data2: Byte); virtual; procedure PutLong(TheSysex: Pointer; msgLength: Word); virtual; procedure SetVolume(Left: Word; Right: Word); constructor Create(AOwner: TComponent); override; destructor Destroy; override; { Some functions to decode and classify incoming messages would be nice } published { TODO: Property editor with dropdown list of product names } property ProductName: string read FProductName write SetProductName; property DeviceID: Cardinal read FDeviceID write SetDeviceID default 0; { TODO: midiOutGetVolume? Or two properties for Left and Right volume? Is it worth it?? midiOutMessage?? Does anyone use this? } { Events } property Onmidioutput: TNotifyEvent read FOnmidioutput write FOnmidioutput; end; procedure Register; {-------------------------------------------------------------------} implementation (* Not used in Delphi 3 { This is the callback procedure in the external DLL. It's used when midioutOpen is called by the Open method. There are special requirements and restrictions for this callback procedure (see midioutOpen in MMSYSTEM.HLP) so it's impractical to make it an object method } {$IFDEF WIN32} function midiHandler( hMidiIn: HMidiIn; wMsg: UINT; dwInstance: DWORD; dwParam1: DWORD; dwParam2: DWORD): Boolean; stdcall; external 'DELMID32.DLL'; {$ELSE} function midiHandler( hMidiIn: HMidiIn; wMsg: Word; dwInstance: DWORD; dwParam1: DWORD; dwParam2: DWORD): Boolean; far; external 'DELPHMID.DLL'; {$ENDIF} *) {-------------------------------------------------------------------} constructor Tmidioutput.Create(AOwner: TComponent); begin inherited Create(AOwner); FState := mosClosed; FNumdevs := midiOutGetNumDevs; { Create the window for callback notification } if not (csDesigning in ComponentState) then begin Handle := AllocateHwnd(MidiOutput); end; end; {-------------------------------------------------------------------} destructor Tmidioutput.Destroy; begin if FState = mosOpen then Close; 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 midioutGetErrorText. TODO: These errors aren't very helpful (e.g. "an invalid parameter was passed to a system function") so some proper error strings would be nice. } function Tmidioutput.midioutErrorString(WError: Word): string; var errorDesc: PChar; begin errorDesc := nil; try errorDesc := StrAlloc(MAXERRORLENGTH); if midioutGetErrorText(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 output device ID and change the other properties to match } procedure Tmidioutput.SetDeviceID(DeviceID: Cardinal); var midioutCaps: TmidioutCaps; begin if FState = mosOpen then raise EmidioutputError.Create('Change to DeviceID while device was open') else if (DeviceID >= midioutGetNumDevs) and (DeviceID <> MIDI_MAPPER) then raise EmidioutputError.Create('Invalid device ID') else begin FDeviceID := DeviceID; { Set the name and other midioutCAPS properties to match the ID } FError := midioutGetDevCaps(DeviceID, @midioutCaps, sizeof(TmidioutCaps)); if Ferror > 0 then raise EmidioutputError.Create(midioutErrorString(FError)); with midiOutCaps do begin FProductName := StrPas(szPname); FDriverVersion := vDriverVersion; FTechnology := OutPortTech(wTechnology); FVoices := wVoices; FNotes := wNotes; FChannelMask := wChannelMask; FSupport := dwSupport; end; end; end; {-------------------------------------------------------------------} { Set the product name property and put the matching output device number in FDeviceID. This is handy if you want to save a configured output/output device by device name instead of device number, because device numbers may change if users install or remove MIDI devices. Exception if output device with matching name not found, or if output device is open } procedure Tmidioutput.SetProductName(NewProductName: string); var midioutCaps: TmidioutCaps; testDeviceID: Integer; testProductName: string; begin if FState = mosOpen then raise EmidioutputError.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 { Loop uses -1 to test for MIDI_MAPPER as well } for testDeviceID := -1 to (midioutGetNumDevs - 1) do begin FError := midioutGetDevCaps(testDeviceID, @midioutCaps, sizeof(TmidioutCaps)); if Ferror > 0 then raise EmidioutputError.Create(midioutErrorString(FError)); testProductName := StrPas(midioutCaps.szPname); if testProductName = NewProductName then begin FProductName := NewProductName; Break; end; end; if FProductName <> NewProductName then raise EmidioutputError.Create('MIDI output Device ' + NewProductName + ' not installed') else SetDeviceID(testDeviceID); end; end; {-------------------------------------------------------------------} { Set the output technology property and put the matching output device number in FDeviceID. This is handy, for example, if you want to be able to switch between a sound card and a MIDI port } procedure TMidiOutput.SetTechnology(NewTechnology: OutPortTech); var midiOutCaps: TMidiOutCaps; testDeviceID: Integer; testTechnology: OutPortTech; begin if FState = mosOpen then raise EMidiOutputError.Create( 'Change to Product Technology while device was open') else begin { Loop uses -1 to test for MIDI_MAPPER as well } for testDeviceID := -1 to (midiOutGetNumDevs - 1) do begin FError := midiOutGetDevCaps(testDeviceID, @midiOutCaps, sizeof(TMidiOutCaps)); if Ferror > 0 then raise EMidiOutputError.Create(MidiOutErrorString(FError)); testTechnology := OutPortTech(midiOutCaps.wTechnology); if testTechnology = NewTechnology then begin FTechnology := NewTechnology; Break; end; end; if FTechnology <> NewTechnology then raise EMidiOutputError.Create('MIDI output technology ' + TechName[NewTechnology] + ' not installed') else SetDeviceID(testDeviceID); end; end; {-------------------------------------------------------------------} function Tmidioutput.Open: Boolean; var hMem: THandle; begin Result := False; try { Create the control info for the DLL } if (PCtlInfo = nil) then begin PCtlInfo := GlobalSharedLockedAlloc(Sizeof(TMidiCtlInfo), hMem); PctlInfo^.hMem := hMem; end; Pctlinfo^.hWindow := Handle; { Control's window handle } FError := midioutOpen(@FMidiHandle, FDeviceId, DWORD(@midiHandler), DWORD(PCtlInfo), CALLBACK_FUNCTION); { FError := midioutOpen(@FMidiHandle, FDeviceId, Handle, DWORD(PCtlInfo), CALLBACK_WINDOW); } if (FError <> 0) then { TODO: use CreateFmtHelp to add MIDI device name/ID to message } raise EmidioutputError.Create(midioutErrorString(FError)) else begin Result := True; FState := mosOpen; end; except if PCtlInfo <> nil then begin GlobalSharedLockedFree(PCtlInfo^.hMem, PCtlInfo); PCtlInfo := nil; end; end; end; {-------------------------------------------------------------------} procedure TMidiOutput.PutShort(MidiMessage: Byte; Data1: Byte; Data2: Byte); var thisMsg: DWORD; begin thisMsg := DWORD(MidiMessage) or (DWORD(Data1) shl 8) or (DWORD(Data2) shl 16); FError := midiOutShortMsg(FMidiHandle, thisMsg); if Ferror > 0 then raise EmidioutputError.Create(midioutErrorString(FError)); end; {-------------------------------------------------------------------} procedure TMidiOutput.PutLong(TheSysex: Pointer; msgLength: Word); { Notes: This works asynchronously; you send your sysex output by calling this function, which returns immediately. When the MIDI device driver has finished sending the data the MidiOutPut function in this component is called, which will in turn call the OnMidiOutput method if the component user has defined one. } { TODO: Combine common functions with PutTimedLong into subroutine } var MyMidiHdr: TMyMidiHdr; begin { Initialize the header and allocate buffer memory } MyMidiHdr := TMyMidiHdr.Create(msgLength); { Copy the data over to the MidiHdr buffer We can't just use the caller's PChar because the buffer memory has to be global, shareable, and locked. } StrMove(MyMidiHdr.SysexPointer, TheSysex, msgLength); { Store the MyMidiHdr address in the header so we can find it again quickly (see the MidiOutput proc) } MyMidiHdr.hdrPointer^.dwUser := DWORD(MyMidiHdr); { Get MMSYSTEM's blessing for this header } FError := midiOutPrepareHeader(FMidiHandle, MyMidiHdr.hdrPointer, sizeof(TMIDIHDR)); if Ferror > 0 then raise EMidiOutputError.Create(MidiOutErrorString(FError)); { Send it } FError := midiOutLongMsg(FMidiHandle, MyMidiHdr.hdrPointer, sizeof(TMIDIHDR)); if Ferror > 0 then raise EMidiOutputError.Create(MidiOutErrorString(FError)); end; {-------------------------------------------------------------------} procedure Tmidioutput.PutMidiEvent(theEvent: TMyMidiEvent); begin if FState <> mosOpen then raise EMidiOutputError.Create('MIDI Output device not open'); with theEvent do begin if Sysex = nil then begin PutShort(MidiMessage, Data1, Data2) end else PutLong(Sysex, SysexLength); end; end; {-------------------------------------------------------------------} function Tmidioutput.Close: Boolean; begin Result := False; if FState = mosOpen then begin { Note this sends a lot of fast control change messages which some synths can't handle. TODO: Make this optional. } { FError := midioutReset(FMidiHandle); if Ferror <> 0 then raise EMidiOutputError.Create(MidiOutErrorString(FError)); } FError := midioutClose(FMidiHandle); if Ferror <> 0 then raise EMidiOutputError.Create(MidiOutErrorString(FError)) else Result := True; end; FMidiHandle := 0; FState := mosClosed; end; {-------------------------------------------------------------------} procedure TMidiOutput.SetVolume(Left: Word; Right: Word); var dwVolume: DWORD; begin dwVolume := (DWORD(Left) shl 16) or Right; FError := midiOutSetVolume(DeviceID, dwVolume); if Ferror <> 0 then raise EMidiOutputError.Create(MidiOutErrorString(FError)); end; {-------------------------------------------------------------------} procedure Tmidioutput.midioutput(var Message: TMessage); { Triggered when sysex output from PutLong is complete } var MyMidiHdr: TMyMidiHdr; thisHdr: PMidiHdr; begin if Message.Msg = Mom_Done then begin { Find the MIDIHDR we used for the output. Message.lParam is its address } thisHdr := PMidiHdr(Message.lParam); { Remove it from the output device } midiOutUnprepareHeader(FMidiHandle, thisHdr, sizeof(TMIDIHDR)); { Get the address of the MyMidiHdr object containing this MIDIHDR structure. We stored this address in the PutLong procedure } MyMidiHdr := TMyMidiHdr(thisHdr^.dwUser); { Header and copy of sysex data no longer required since output is complete } MyMidiHdr.Free; { Call the user's event handler if any } if Assigned(FOnmidioutput) then FOnmidioutput(Self); end; { TODO: Case for MOM_PLAYBACK_DONE } end; {-------------------------------------------------------------------} procedure Register; begin RegisterComponents('Synth', [Tmidioutput]); end; end.