unit MidiMain;

{Idee: Robert Roßmair}

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, Buttons, MMSystem;

type
  TForm1 = class(TForm)
    SpeedButton1: TSpeedButton;
    SpeedButton2: TSpeedButton;
    SpeedButton3: TSpeedButton;
    SpeedButton4: TSpeedButton;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure SpeedButton1MouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure SpeedButton1MouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
  private
    { Private-Deklarationen }
    MidiOut: hMidiOut;
    MidiOutOpened: Boolean;
  public
    { Public-Deklarationen }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

type
  TMidiChannel = 0..$F;
  TMidiData = 0..$7F;
  TMidiShortMsg = packed record
  case Integer of
    0: (DWord: DWORD);
    1: (StatusByte: Byte;
        DataByte1,
        DataByte2: Byte);
    2: { Running status }
       (RDataByte1,
        RDataByte2: Byte);
  end;

const
  MidiDataMask = $7F;
  MidiChannelMask = $F;
  RunningStatus: Byte = 0;

procedure MidiNoteOn(Device: hMidiOut;
                     Channel: TMidiChannel;
                     Key: TMidiData;
                     Velocity: TMidiData);
var
  Msg: TMidiShortMsg;
begin
  with Msg do begin
    StatusByte := $90 or Byte(Channel and MidiChannelMask);
    if StatusByte = RunningStatus then begin
      RDataByte1 := Key and MidiDataMask;
      RDataByte2 := Velocity and MidiDataMask;
    end
    else begin
      RunningStatus := StatusByte;
      DataByte1 := Key and MidiDataMask;
      DataByte2 := Velocity and MidiDataMask;
    end;
    midiOutShortMsg(Device, DWord);
  end;
end;

procedure MidiNoteOff(Device: hMidiOut;
                      Channel: TMidiChannel;
                      Key: TMidiData;
                      Velocity: TMidiData);
var
  Msg: TMidiShortMsg;
begin
  with Msg do begin
    StatusByte := $80 or Byte(Channel and MidiChannelMask);
    if StatusByte = RunningStatus then begin
      RDataByte1 := Key and MidiDataMask;
      RDataByte2 := Velocity and MidiDataMask;
    end
    else begin
      RunningStatus := StatusByte;
      DataByte1 := Key and MidiDataMask;
      DataByte2 := Velocity and MidiDataMask;
    end;
    midiOutShortMsg(Device, DWord);
  end;
end;

function OpenFMSynth(var MidiOut: hMidiOut): Boolean;
var
  I: Integer;
  Caps: TMidiOutCaps;
begin
  for I := 0 to midiOutGetNumDevs-1 do begin
    if (midiOutGetDevCaps(I, @Caps, SizeOf(Caps)) = MMSYSERR_NOERROR)
     and (Caps.wTechnology = MOD_FMSYNTH) then begin
      Result := midiOutOpen(@MidiOut, I, 0, 0, 0) = MMSYSERR_NOERROR;
      if Result then
        Exit;
    end;
  end;
  Result := False;
end;

procedure TForm1.SpeedButton1MouseDown(Sender: TObject;
  Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var KeyNr : byte;
begin
  KeyNr:=(Sender as TSpeedButton).Tag;
  MidiNoteOn(MidiOut, 0, KeyNr, 127);
end;

procedure TForm1.SpeedButton1MouseUp(Sender: TObject; Button:
TMouseButton; Shift: TShiftState; X, Y: Integer);
var KeyNr : byte;
begin
  KeyNr:=(Sender as TSpeedButton).Tag;
  MidiNoteOff(MidiOut, 0, KeyNr, 127);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  MidiOutOpened := OpenFMSynth(MidiOut);
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  midiOutClose(MidiOut);
end;

end.