diff options
Diffstat (limited to 'Game/Code/lib/midi/Midiout.pas')
| -rw-r--r-- | Game/Code/lib/midi/Midiout.pas | 600 |
1 files changed, 600 insertions, 0 deletions
diff --git a/Game/Code/lib/midi/Midiout.pas b/Game/Code/lib/midi/Midiout.pas new file mode 100644 index 00000000..91b75073 --- /dev/null +++ b/Game/Code/lib/midi/Midiout.pas @@ -0,0 +1,600 @@ +{ $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
+
+uses
+ SysUtils, WinTypes, WinProcs, Messages, Classes, Controls, Forms,
+ MMSystem, Circbuf, MidiType, MidiDefs, Delphmcb;
+
+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: Integer; { 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: Version; { 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: Integer);
+ procedure SetProductName(NewProductName: string);
+ procedure SetTechnology(NewTechnology: OutPortTech);
+ function midioutErrorString(WError: Word): string;
+
+ public
+ { Properties }
+ property MIDIHandle: Hmidiout read FMIDIHandle;
+ property DriverVersion: Version { 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: Integer 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: Integer);
+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.
+
|