FEATURE: adding tone output

BUG: program will not stop if a delay is used.

Beispiele/Tone.tps

@@ -0,0 +1,15 @@
+#TPS:Willies SPS Arduino
+0x00,4,3,""
+0x01,5,1,""
+0x02,4,0,""
+0x03,7,C,""
+0x04,F,8,""
+0x05,2,9,""
+0x06,4,0,""
+0x07,5,1,""
+0x08,4,0,""
+0x09,7,C,""
+0x0A,F,8,""
+0x0B,2,8,""
+0x0C,3,C,""
+0x0D,0,0,""

README.md

@@ -1,4 +1,7 @@
 # **SPS_Emulator Version History**
+**12.12.2018 Version 0.2.1.57**
+  
+  * FEATURE: Tone Mnemonic now gives a real tone output.
 
 **10.12.2018 Version 0.2.1.56**
   

SPS_EMU.000

@@ -2,8 +2,8 @@
 LSUTextFile=1
 Copyrigth=MCS Media Computer Software
 [LSUInfo]
-CompileDate=10.12.2018
-CompileTime=14:08:28
+CompileDate=12.12.2018
+CompileTime=00:25:33
 Name=Wilfried Klaas
 LSUBinFile=E:\daten\git-sourcen\SPS_Emulator\SPS_Emu.lsu
 LSUTextFile=E:\daten\git-sourcen\SPS_Emulator\SPS_Emu.

SPS_Emu.lpi

@@ -22,7 +22,7 @@
       <AutoIncrementBuild Value="True"/>
       <MinorVersionNr Value="2"/>
       <RevisionNr Value="1"/>
-      <BuildNr Value="56"/>
+      <BuildNr Value="57"/>
       <Language Value="0407"/>
       <StringTable CompanyName="MCS" FileDescription="TPS/SPS Emulator" InternalName="SPS_EMU" LegalCopyright="MCS (C) Wilfried Klaas" OriginalFilename="SPS_EMU.exe" ProductName="TPS/SPS Emulator" ProductVersion="0.2"/>
     </VersionInfo>
@@ -38,7 +38,7 @@
     <RunParams>
       <local>
         <FormatVersion Value="1"/>
-        <CommandLineParams Value="beispiele/SimpleServo.tps"/>
+        <CommandLineParams Value="beispiele/tone.tps"/>
       </local>
       <environment>
         <UserOverrides Count="1">

midi.pas

@@ -0,0 +1,582 @@
+unit MIDI;
+
+{$ifdef fpc}
+  {$mode objfpc}{$H+}
+{$endif}
+
+
+{ ***   You can choose if You want MIDI.PAS to use exceptions    *** }
+{ ***   in case of Errors. If not, MIDI.PAS uses POSTMESSAGE()   *** }
+{ ***   and You have to handle these messages in Your MainForm   *** }
+
+//{$define MIDI_UseExceptions}
+
+//{$define DebugSysEx}
+
+
+{*******************************************************************************
+*                                                                              *
+*                                MIDI.PAS                                      *
+*                                                                              *
+*     This file is based on the MIDI device classes by Adrian Meyer            *
+*     This file was taken from the ZIP archive 'demo_MidiDevices_D6.zip'       *
+*     and partly changed by me, some changes take over from  'DAV_MidiIO.pas'  *
+*                                                                              *
+*                       latest changes 2015-04-13                              *
+********************************************************************************
+* V1.0  First release with simple MIDI Input/Output                            *
+* V1.1  SysEx Input Event added, refactured error handling                     *
+* V1.2  SysEx Output procedure added, changes sysex input for multiple ports   *
+* V1.3  Changes by BREAKOUTBOX 2009-07  (www.breakoutbox.de)                   *
+* V1.4  Changes adapted from DAV_MidiIO.pas - see http://www.ohloh.net/p/DAV   *
+* V1.5  removed an Exception on sending SysEx Data to a CLOSED Output          *
+* V1.6  added a Switch to choose between Exceptions and Other behaviore ...    *
+* V1.7  replaced  pChar => pAnsiChar  Char => AnsiChar  string => AnsiString   *
+*       to gain compatibility to DelphiXE and higher versions ..               *
+*       -                                                                      *
+*******************************************************************************}
+
+
+interface
+
+uses
+  {$ifdef FPC}
+  Interfaces,
+  JWAwindows,
+  {$else}
+  Windows,
+  {$endif}
+  Forms, Classes, Messages, SysUtils, Math, Contnrs, MMSystem, Dialogs;
+
+
+// -------------------------- WARNING --------------------------
+// If Your Application uses User-defined Messages YOU MUST CHECK
+// if these values collide with one of Your own messages !!!
+const
+  // define window messages for MainForm :
+  WM_MIDISYSTEM_MESSAGE = WM_USER +1;
+  WM_MIDIDATA_ARRIVED   = WM_USER +2;
+  WM_MIM_ERROR          = WM_USER +3;//1001;
+  WM_MIM_LONGERROR      = WM_USER +4;//1002;
+
+
+const
+  // define Your size of  System Exclusive buffer :
+  cMySysExBufferSize = 2048;
+
+
+
+type
+  TMIDIChannel      = 1..16;
+  TMIDIDataByte     = 0..$7F;           //  7 bits
+  TMIDIDataWord     = 0..$3FFF;         // 14 bits
+  TMIDIStatusByte   = $80..$FF;
+  TMIDIVelocity     = TMIDIDataByte;
+  TMIDIKey          = TMIDIDataByte;
+  TMIDINote         = TMIDIKey;
+
+type
+  // event if data is received
+  TOnMidiInData = procedure (const aDeviceIndex: integer; const aStatus, aData1, aData2: byte) of object;
+  // event if system exclusive data is received
+  TOnSysExData = procedure (const aDeviceIndex: integer; const aStream: TMemoryStream) of object;
+
+  EMidiDevices = Exception;
+
+  // base class for MIDI devices
+  TMidiDevices = class
+  private
+    fDevices    : TStringList;
+    fMidiResult : MMResult;
+    procedure SetMidiResult(const Value: MMResult);
+  protected
+    property MidiResult: MMResult read fMidiResult write SetMidiResult;
+    function GetHandle(const aDeviceIndex: integer): THandle;
+  public
+    // create the MIDI devices
+    constructor Create; virtual;
+    // whack the devices
+    destructor Destroy; override;
+    // open a specific device
+    procedure Open(const aDeviceIndex: integer); virtual; abstract;
+    // close a specific device
+    procedure Close(const aDeviceIndex: integer); virtual; abstract;
+    // close all devices
+    procedure CloseAll;
+    // THE devices
+    function IsOpen(ADeviceIndex: Integer): Boolean;                            // check if open
+    property Devices: TStringList read fDevices;
+  end;
+
+  // MIDI input devices
+  TMidiInput = class(TMidiDevices)
+  private
+    fOnMidiData  : TOnMidiInData;
+    fOnSysExData : TOnSysExData;
+    fSysExData   : TObjectList;
+  protected
+    procedure DoSysExData( const aDeviceIndex: integer);
+  public
+    // create an input device
+    constructor Create; override;
+    // what the input devices
+    destructor Destroy; override;
+    // open a specific input device
+    procedure Open( const aDeviceIndex: integer); override;
+    // close a specific device
+    procedure Close( const aDeviceIndex: integer); override;
+    // midi data event
+    property OnMidiData: TOnMidiInData read fOnMidiData write fOnMidiData;
+    // midi system exclusive is received
+    property OnSysExData: TOnSysExData read fOnSysExData write fOnSysExData;
+  end;
+
+  // MIDI output devices
+  TMidiOutput = class(TMidiDevices)
+    constructor Create; override;
+    // open a specific input device
+    procedure Open(const aDeviceIndex: integer); override;
+    // close a specific device
+    procedure Close(const aDeviceIndex: integer); override;
+    // send some midi data to the indexed device
+    procedure Send(const aDeviceIndex: integer; const aStatus, aData1, aData2: byte);
+    procedure SendSystemReset( const aDeviceIndex: integer);
+    procedure SendAllSoundOff( const aDeviceIndex: integer; const channel: byte);
+    // send system exclusive data to a device
+    procedure SendSysEx( const aDeviceIndex: integer; const aStream: TMemoryStream); overload;
+    procedure SendSysEx( const aDeviceIndex: integer; const aString: AnsiString); overload;
+  end;
+
+  // convert the stream into xx xx xx xx AnsiString
+  function SysExStreamToStr( const aStream: TMemoryStream): AnsiString;
+  // fill the AnsiString in a xx xx xx xx into the stream  
+  procedure StrToSysExStream( const aString: AnsiString; const aStream: TMemoryStream);
+
+  // MIDI input devices
+  function MidiInput: TMidiInput;
+  // MIDI output Devices
+  function MidiOutput: TMidiOutput;
+
+
+  type
+    TSysExBuffer = array[0..cMySysExBufferSize -1] of AnsiChar;
+
+    TSysExData = class
+    private
+      fSysExStream: TMemoryStream;
+    public
+      SysExHeader: {$ifdef FPC} _midihdr {$else} TMidiHdr {$endif};
+      SysExData: TSysExBuffer;
+      constructor Create;
+      destructor Destroy; override;
+      property   SysExStream: TMemoryStream read fSysExStream;
+    end;
+
+
+
+implementation
+
+
+{ ***** TMidiBase ************************************************************ }
+constructor TMidiDevices.Create;
+begin
+  FDevices:= TStringList.Create;
+end;
+
+destructor TMidiDevices.Destroy;
+begin
+  FreeAndNil( FDevices);
+  inherited;
+end;
+
+
+var
+  gMidiInput: TMidiInput;
+  gMidiOutput: TMidiOutput;
+
+
+function MidiInput: TMidiInput;
+begin
+  if not Assigned( gMidiInput)
+    then gMidiInput := TMidiInput.Create;
+  Result := gMidiInput;
+end;
+
+function MidiOutput: TMidiOutput;
+begin
+  if not Assigned( gMidiOutput)
+    then gMidiOutput := TMidiOutput.Create;
+  Result := gMidiOutput;
+end;
+
+
+{$IFDEF FPC}
+//type
+//  PHMIDIIN = ^HMIDIIN;
+//  TMidiOutCaps = TMidiOutCapsA;
+{$ENDIF}
+
+{ I don't know whatfor this RECORD is used in DAV_MidiIO.pas
+  but I think this maybe allows renumeration / resorting of MIDI devices
+  for use in Your application - I didn't use this until now
+  so I didn't take over the implementation in this MIDI.PAS ... !
+
+TMidiInputDeviceRecord = record
+    MidiInput    : TMidiInput;
+    DeviceNumber : Integer;
+  end;
+  PMidiInputDeviceRecord = ^TMidiInputDeviceRecord;
+}
+
+
+{ The Callback-Procedure receives MIDI data on interrupt : }
+procedure MidiInCallback( aMidiInHandle: PHMIDIIN; aMsg: Integer; aInstance,
+                          aMidiData, aTimeStamp: integer); stdcall;
+begin
+  case aMsg of
+    MIM_DATA:
+      begin
+        if Assigned(MidiInput.OnMidiData) then
+          begin
+            MidiInput.OnMidiData(   aInstance,
+                                    aMidiData and $000000FF,
+                                  ( aMidiData and $0000FF00) shr 8,
+                                  ( aMidiData and $00FF0000) shr 16);
+            PostMessage( Application.MainForm.Handle, WM_MIDIDATA_ARRIVED, aInstance, aMidiData);
+          end;
+      end;
+
+    MIM_LONGDATA:
+      MidiInput.DoSysExData( aInstance);
+
+    MIM_ERROR:  PostMessage( Application.MainForm.Handle, WM_MIM_ERROR, aInstance, aMidiData);
+
+    MIM_LONGERROR:
+      {$ifdef MIDI_UseExceptions}
+      raise Exception.Create( 'Midi In Error!');
+      {$else} // in a Callback Function you CANNOT use a MessageBox()  !!!
+      PostMessage( Application.MainForm.Handle, WM_MIM_LONGERROR, aInstance, aMidiData);
+      {$endif}
+  end;
+end;
+
+
+{ ***** TMidiInput *********************************************************** }
+constructor TMidiInput.Create;
+var
+  AvailableMIDIinputs : integer;
+  lInCaps             : TMidiInCaps;
+  i                   : integer;
+begin
+  inherited;
+  fSysExData := TObjectList.Create(true);
+  TRY   // TRY..EXCEPT was adapted from file "DAV_MidiIO.pas"
+    AvailableMIDIinputs:= MidiInGetNumDevs;
+  EXCEPT
+    AvailableMIDIinputs:= 0;
+  end;
+
+  if AvailableMIDIinputs > 0 then
+  for i:= 0 to AvailableMIDIinputs - 1 do
+  begin
+    MidiResult := midiInGetDevCaps(i, @lInCaps, SizeOf(TMidiInCaps));
+    if MidiResult = MMSYSERR_NOERROR then
+      begin
+        fDevices.Add(StrPas(lInCaps.szPname));
+        fSysExData.Add(TSysExData.Create);
+      end;
+  end;
+end;
+
+destructor TMidiInput.Destroy;
+begin
+  FreeAndNil( fSysExData);
+  inherited;
+end;
+
+procedure TMidiInput.Close( const aDeviceIndex: integer);
+begin
+  if GetHandle( aDeviceIndex) <> 0 then
+  begin
+    MidiResult := midiInStop(GetHandle(aDeviceIndex));
+    MidiResult := midiInReset(GetHandle(aDeviceIndex));
+    MidiResult := midiInUnprepareHeader(GetHandle(aDeviceIndex),
+                  @TSysExData(fSysExData[aDeviceIndex]).SysExHeader, SizeOf(TMidiHdr));
+    MidiResult := midiInClose(GetHandle(aDeviceIndex));
+    FDevices.Objects[aDeviceIndex] := nil;
+  end;
+end;
+                         
+procedure TMidiDevices.CloseAll;
+var
+  i : integer;
+begin
+  for i:= 0 to FDevices.Count - 1 do Close(i);
+end;
+
+procedure TMidiInput.Open( const aDeviceIndex: integer);
+var
+  lSysExData : TSysExData;
+  lHandle    : THandle;
+begin
+  if GetHandle(aDeviceIndex) <> 0 then Exit;
+
+  MidiResult := midiInOpen( @lHandle, aDeviceIndex, cardinal(@midiInCallback),
+                            aDeviceIndex, CALLBACK_FUNCTION);
+
+  fDevices.Objects[ aDeviceIndex ] := TObject(lHandle);
+  lSysExData := TSysExData(fSysExData[aDeviceIndex]);
+
+  lSysExData.SysExHeader.dwFlags := 0;
+
+  // DRAGONS:  why are the function returns not checked on errors here ?
+  MidiResult := midiInPrepareHeader(lHandle, @lSysExData.SysExHeader, SizeOf(TMidiHdr));
+  MidiResult := midiInAddBuffer( lHandle, @lSysExData.SysExHeader, SizeOf(TMidiHdr));
+  MidiResult := midiInStart( lHandle);
+end;
+
+
+{ ***** TMidiInput - SysEx *************************************************** }
+procedure TMidiInput.DoSysExData( const aDeviceIndex: integer);
+var
+  lSysExData : TSysExData;
+begin
+  lSysExData := TSysExData(fSysExData[aDeviceIndex]);
+  if lSysExData.SysExHeader.dwBytesRecorded = 0 then Exit;
+
+  lSysExData.SysExStream.Write( lSysExData.SysExData,
+                                lSysExData.SysExHeader.dwBytesRecorded);
+  if lSysExData.SysExHeader.dwFlags and MHDR_DONE = MHDR_DONE then
+  begin
+    lSysExData.SysExStream.Position := 0;
+    if assigned(fOnSysExData)
+      then fOnSysExData(aDeviceIndex, lSysExData.SysExStream);
+    lSysExData.SysExStream.Clear;
+  end;
+
+  lSysExData.SysExHeader.dwBytesRecorded := 0;
+
+  // DRAGONS:  why not check function returns on errors here ?
+  MidiResult := MidiInPrepareHeader( GetHandle(aDeviceIndex),
+                                     @lSysExData.SysExHeader, SizeOf(TMidiHdr));
+  MidiResult := MidiInAddBuffer( GetHandle(aDeviceIndex), @lSysExData.SysExHeader,
+                                 SizeOf( TMidiHdr));
+end;
+
+
+{ ***** TMidiOutput ********************************************************** }
+constructor TMidiOutput.Create;
+var
+  AvailableMIDIoutputs : integer;
+  lOutCaps             : TMidiOutCaps;
+  i                    : integer;
+begin
+  inherited;
+
+  TRY
+    AvailableMIDIoutputs := MidiOutGetNumDevs;
+  EXCEPT
+    AvailableMIDIoutputs := 0;
+  end;
+
+  //ShowMessage( 'DEBUG - AvailableMIDIoutputs = ' +IntToStr( AvailableMIDIoutputs));
+  for i:= 0 to AvailableMIDIoutputs - 1 do
+  begin
+    MidiResult := MidiOutGetDevCaps( i, @lOutCaps, SizeOf(TMidiOutCaps));
+    fDevices.Add( lOutCaps.szPname);
+  end;
+end;
+
+procedure TMidiOutput.Open( const aDeviceIndex: integer);
+var
+  lHandle: THandle;
+begin
+  {$ifndef FPC}
+  inherited;  // Lazarus doesn't like this, so for Delphi only ..
+  {$endif}
+  // device already open;
+  if GetHandle(aDeviceIndex) <> 0 then exit;
+
+  MidiResult := midiOutOpen( @lHandle, aDeviceIndex, 0, 0, CALLBACK_NULL);
+  fDevices.Objects[ aDeviceIndex ]:= TObject( lHandle);
+end;
+
+procedure TMidiOutput.Close( const aDeviceIndex: integer);
+begin
+  {$ifndef FPC}
+  inherited;  // Lazarus doesn't like this, so for Delphi only ..
+  {$endif}
+  if GetHandle(aDeviceIndex) <> 0 then // 'if .. then' added by BREAKOUTBOX 2009-07-15
+    begin
+      MidiResult := midiOutClose(GetHandle(aDeviceIndex));
+      fDevices.Objects[ aDeviceIndex ] := nil;
+    end;
+end;
+
+procedure TMidiOutput.Send( const aDeviceIndex: integer; const aStatus,
+                            aData1, aData2: byte);
+var
+  lMsg: cardinal;
+begin
+  // open if the device is not open      // NOW: do NOT open .. !
+  if not Assigned( fDevices.Objects[ aDeviceIndex ])
+    then exit;  // Open( aDeviceIndex);  // Breakoutbox changed 2008-07-01
+
+  //lMsg := aStatus + (aData1 * $100) + (aData2 * $10000);
+  lMsg:= aStatus or (aData1 shl 8) or (aData2 shl 16); // better ?
+  MidiResult := MidiOutShortMsg( GetHandle( aDeviceIndex), lMSG);
+end;
+
+{ --- common MIDI Out messages ----------------------------------------------- }
+{ System Reset = Status Byte FFh }
+procedure TMidiOutput.SendSystemReset( const aDeviceIndex: integer);
+begin
+  Self.Send( aDeviceIndex, $FF, $0, $0);
+end;
+
+{ All Sound Off = Status + Channel Byte Bnh, n = Channel number  }
+{                 Controller-ID = Byte 78h,  2nd Data-Byte = 00h }
+procedure TMidiOutput.SendAllSoundOff(const aDeviceIndex: integer; const channel: byte);
+begin
+  Self.Send( aDeviceIndex, $b0 +channel, $78, $0);
+end;
+
+// HINT:  in a Thread MidiInGetErrorText() makes no sense ..
+//        read out the error text in Your main thread / MainForm !
+procedure TMidiDevices.SetMidiResult( const Value: MMResult);
+var
+  lError: array[0..MAXERRORLENGTH] of AnsiChar;
+begin
+  fMidiResult := Value;
+  if fMidiResult <> MMSYSERR_NOERROR then
+    if MidiInGetErrorText( fMidiResult, @lError, MAXERRORLENGTH) = MMSYSERR_NOERROR
+      {$ifdef MIDI_UseExceptions}
+      then raise EMidiDevices.Create(StrPas(lError));
+      {$else}
+      // in a Thread or a Callback Function you CANNOT use a MessageBox()  !!!
+      //then ShowMessage( 'ERROR in  TMidiDevices.SetMidiResult()  Line 409' +#13#13
+      //                  +StrPas( lError) );
+      then PostMessage( Application.MainForm.Handle, WM_MIDISYSTEM_MESSAGE, fMidiResult, 0);
+      {$endif}
+end;
+
+function TMidiDevices.GetHandle( const aDeviceIndex: integer): THandle;
+begin
+  try
+    if not InRange(aDeviceIndex, 0, fDevices.Count - 1) then
+      raise EMidiDevices.CreateFmt( '%s: Device index out of bounds! (%d)',
+                                    [ClassName,aDeviceIndex]);
+
+    Result:= THandle(fDevices.Objects[ aDeviceIndex ]);
+  except
+    Result:= 0;
+  end;
+end;
+
+function TMidiDevices.IsOpen(ADeviceIndex: Integer): boolean;
+begin
+  Result := GetHandle(ADeviceIndex) <> 0;
+end;
+
+
+{ ***** TMidiOutput - SysEx ************************************************** }
+procedure TMidiOutput.SendSysEx( const aDeviceIndex: integer;
+                                 const aString: AnsiString);
+var
+  lStream: TMemoryStream;
+begin
+  lStream := TMemoryStream.Create;
+  try
+    StrToSysExStream( aString, lStream);
+    SendSysEx( aDeviceIndex, lStream);
+  finally
+    FreeAndNil( lStream);
+  end;
+end;
+
+procedure TMidiOutput.SendSysEx( const aDeviceIndex: integer;
+                                 const aStream: TMemoryStream);
+var
+  lSysExHeader: TMidiHdr;
+begin
+  // exit here if DeviceIndex is not open !
+  if not assigned(fDevices.Objects[ aDeviceIndex ])
+    then exit; // Breakoutbox added this 2013-06-15
+
+  aStream.Position := 0;
+  lSysExHeader.dwBufferLength := aStream.Size;
+  lSysExHeader.lpData := aStream.Memory;
+  lSysExHeader.dwFlags := 0;
+
+  //ShowMessage( 'HEX: ' +SysExStreamToStr( aStream));
+  {$ifdef DebugSysEx}  ShowMessage( '0 - ' +IntToStr(MidiResult));  {$endif}
+  MidiResult := midiOutPrepareHeader(GetHandle(aDeviceIndex), @lSysExHeader, SizeOf(TMidiHdr));
+  {$ifdef DebugSysEx}  ShowMessage( '1 - ' +IntToStr(MidiResult));  {$endif}
+  MidiResult := midiOutLongMsg( GetHandle(aDeviceIndex), @lSysExHeader, SizeOf(TMidiHdr));
+  {$ifdef DebugSysEx}  ShowMessage( '2 - ' +IntToStr(MidiResult));  {$endif}
+  MidiResult := midiOutUnprepareHeader(GetHandle(aDeviceIndex), @lSysExHeader, SizeOf(TMidiHdr));
+  {$ifdef DebugSysEx}  ShowMessage( '3 - ' +IntToStr(MidiResult));  {$endif}
+  {$ifdef DebugSysEx}  ShowMessage( '4 - ' +aStream.ReadAnsiString);  {$endif}
+end;
+
+
+{ ***** TSysExData *********************************************************** }
+constructor TSysExData.Create;
+begin
+  SysExHeader.dwBufferLength := cMySysExBufferSize;
+  SysExHeader.lpData := SysExData;
+  fSysExStream := TMemoryStream.Create;
+end;
+
+destructor TSysExData.Destroy;
+begin
+  FreeAndNil( fSysExStream);
+end;
+
+
+{ ***** Helper Funktions ***************************************************** }
+function SysExStreamToStr(const aStream: TMemoryStream): AnsiString;
+var
+  i : integer;
+begin
+  Result := '';
+  aStream.Position:= 0;
+  for i:= 0 to aStream.Size - 1
+    do Result := Result + Format( '%.2x ', [ byte(pAnsiChar(aStream.Memory)[i]) ]);
+end;
+
+procedure StrToSysExStream(const aString: AnsiString; const aStream: TMemoryStream);
+const
+  cHex : AnsiString = '123456789ABCDEF';
+var
+  lStr : AnsiString;
+  i    : integer;
+  L    : integer;
+begin
+  // check on errors  - added by BREAKOUTBOX 2009-07-30
+  L := length( aString);
+  if not (L mod 2 = 0) // as HEX every byte must be two AnsiChars long, for example '0F'
+    then raise EMidiDevices.Create( 'SysEx string corrupted')
+    else if l < 10  // shortest System Exclusive Message = 5 bytes = 10 hex AnsiChars
+           then raise EMidiDevices.Create( 'SysEx string too short');
+
+  lStr := StringReplace( AnsiUpperCase( aString), ' ', '', [rfReplaceAll]);
+  aStream.Size := Length( lStr) div 2; // ' - 1' removed by BREAKOUTBOX 2009-07-15
+  aStream.Position := 0;
+
+  for i:= 1 to aStream.Size do
+    pAnsiChar( aStream.Memory)[i-1] :=
+      AnsiChar( AnsiPos( lStr[ i*2 - 1], cHex) shl 4 + AnsiPos( lStr[i*2], cHex));
+end;
+
+
+initialization
+  gMidiInput  := nil;
+  gMidiOutput := nil;
+
+finalization
+  FreeAndNil( gMidiInput);
+  FreeAndNil( gMidiOutput);
+
+
+end.

ugui.lfm

@@ -205,6 +205,7 @@ object Form1: TForm1
         Top = 232
         Width = 60
         Enabled = False
+        OnClick = btnToneClick
         Spacing = 2
         TabOrder = 4
       end
@@ -5665,7 +5666,12 @@ object Form1: TForm1
     }
   end
   object XMLPropStorage1: TXMLPropStorage
-    StoredValues = <>
+    StoredValues = <    
+      item
+        Name = 'MidiProgram'
+        Value = '30'
+        KeyString = 'MidiProgram'
+      end>
     left = 496
     top = 496
   end

ugui.pas

@@ -9,7 +9,7 @@ interface
 uses
   Windows, Classes, SysUtils, FileUtil, SdpoSerial, Forms, Controls, Graphics, Dialogs,
   Grids, ExtCtrls, Menus, ComCtrls, ActnList, StdActns, LCLProc, StdCtrls, Spin,
-  XMLPropStorage, uSPS, LCLType, Buttons, types, MCSWINAPI, Math, fpjson, jsonparser;
+  XMLPropStorage, uSPS, LCLType, Buttons, types, MCSWINAPI, Math, fpjson, jsonparser, Midi;
 
 type
 
@@ -155,6 +155,7 @@ type
     procedure acThisStepExecute(Sender: TObject);
     procedure acFileSaveExecute(Sender: TObject);
     procedure acUploadExecute(Sender: TObject);
+    procedure btnToneClick(Sender: TObject);
     procedure cbCommandChange(Sender: TObject);
     procedure cbDataChange(Sender: TObject);
     procedure cbTPSVersionChange(Sender: TObject);
@@ -177,6 +178,9 @@ type
     stopit: boolean;
     activeFile: string;
     dirty: boolean;
+    lastNote: byte;
+    procedure initMidi;
+    procedure playNote(note: byte);
     function readString(var line: string): boolean;
     procedure saveSection(filename: string; key: string);
     procedure loadSection(filename: string; key: string);
@@ -254,6 +258,36 @@ begin
   activateSps(False);
   Timer1.Enabled := True;
   MCSLSU.MakeForm('form1', 'ID_', form1);
+  initMidi;
+end;
+
+procedure TForm1.initMidi;
+var
+  Value: integer;
+begin
+  lastNote := 0;
+  MidiOutput.Open(0);
+  Value := XMLPropStorage1.ReadInteger('MidiProgram', 30);
+  MidiOutput.Send(0, 192, Value, 0);
+end;
+
+procedure TForm1.playNote(note: byte);
+var
+  command, velocity: byte;
+begin
+  if (lastNote > 0) then
+  begin
+    command := $80;
+    velocity := $7F;
+    MidiOutput.Send(0, command, lastnote, velocity);
+  end;
+  if (note > 0) then
+  begin
+    command := $90;
+    velocity := $7F;
+    MidiOutput.Send(0, command, note, velocity);
+  end;
+  lastNote := note;
 end;
 
 procedure TForm1.FormDropFiles(Sender: TObject; const FileNames: array of string);
@@ -703,9 +737,9 @@ begin
     stopit := True;
     sps.break();
     acDebug.ImageIndex := 18;
-    repeat
-      Application.ProcessMessages;
-    until (not sps.isDelayActive());
+    //   repeat
+    //     Application.ProcessMessages;
+    //   until (not sps.isDelayActive());
     sps.doReset();
     acStop.Enabled := False;
     acDebug.Enabled := True;
@@ -748,6 +782,11 @@ begin
   //serialUpload;
 end;
 
+procedure TForm1.btnToneClick(Sender: TObject);
+begin
+  MidiOutput.SendAllSoundOff(0, 0);
+end;
+
 function TForm1.serialUpload: string;
 var
   hexFile: string;
@@ -1339,6 +1378,7 @@ begin
   MCSLabel.Caption := InfoBox.versionText;
 end;
 
+
 procedure TForm1.renumberGrid;
 var
   x, i: integer;
@@ -1420,12 +1460,23 @@ begin
   if (sps.getTone() > 0) then
   begin
     ImageList2.GetBitmap(23, btnTone.Glyph);
-    btnTone.Caption := IntToStr(sps.getTone());
+    i := round(440 * power(2.0, ((sps.getTone() - 69) / 12)));
+    btnTone.Caption := IntToStr(i);
+    if (lastNote <> sps.getTone()) then
+    begin
+      playNote(sps.getTone());
+    end;
+    btntone.Enabled := True;
   end
   else
   begin
     ImageList2.GetBitmap(22, btnTone.Glyph);
     btnTone.Caption := '';
+    if (lastNote <> sps.getTone()) then
+    begin
+      playNote(0);
+    end;
+    btntone.Enabled := False;
   end;
   List := TStringList.Create;
   try

usps.pas

@@ -1115,7 +1115,7 @@ end;
 procedure TSPS.doTone(Data: byte);
 begin
   if (a in [36..109]) then
-    tone := round(440 * power(2.0, ((a - 69) / 12)))
+    tone := a
   else
     tone := 0;
 end;