K210.ORG

unit main;

 

interface

 

uses

   Windows, MMSystem, Messages, SysUtils, Classes, Graphics, Controls, 

Forms, Dialogs, StdCtrls;

const

     PPQN = 96;

     Dur16th = PPQN div 4;

     NoteOn = $99;

     NoteOff = $89;

     Velocity = 96 shl 16;

     VelocityMax = 127 shl 16;

     BassDrum = 35 shl 8;

     ClosedHiHat = 42 shl 8;

     Snare = 38 shl 8;

     BassNoteOn = Velocity + BassDrum + NoteOn;

     BassNoteOff = Velocity + BassDrum + NoteOff;

     HiHatOn = Velocity + ClosedHiHat + NoteOn;

     HiHatOff = Velocity + ClosedHiHat + NoteOff;

     SnareOn = Velocity + Snare + NoteOn;

     SnareOff = Velocity + Snare + NoteOff;

     BassMaxOn = VelocityMax + BassDrum + NoteOn;

     HiHatMaxOn = VelocityMax + ClosedHiHat + NoteOn;

     SnareMaxOn = VelocityMax + Snare + NoteOn;

     DummyNoteOn = $4090;

     DummyNoteOff = $4080;

 

type

     TMIDIEvent = record

         dwDeltaTime: DWORD;

         dwStreamID: DWORD;

         dwEvent: DWORD;

     end;

 

     TDrumEvent = record

         lpData: pointer;

         size: Cardinal;

     end;

 

const

     Drum1: array [0..3] of TMIDIEvent =

         (

             (dwDeltaTime: 0; dwStreamID: 0; dwEvent: BassNoteOn),

             (dwDeltaTime: 0; dwStreamID: 0; dwEvent: HiHatOn),

             (dwDeltaTime: Dur16th; dwStreamID: 0; dwEvent: BassNoteOff),

             (dwDeltaTime: Dur16th; dwStreamID: 0; dwEvent: HiHatOff)

         );

 

     Drum2: array [0..1] of TMIDIEvent =

         (

             (dwDeltaTime: 0; dwStreamID: 0; dwEvent: HiHatOn),

             (dwDeltaTime: Dur16th; dwStreamID: 0; dwEvent: HiHatOff)

         );

 

     Drum3: array [0..5] of TMIDIEvent =

         (

             (dwDeltaTime: 0; dwStreamID: 0; dwEvent: BassMaxOn),

             (dwDeltaTime: 0; dwStreamID: 0; dwEvent: HiHatMaxOn),

             (dwDeltaTime: 0; dwStreamID: 0; dwEvent: SnareMaxOn),

             (dwDeltaTime: Dur16th; dwStreamID: 0; dwEvent: BassNoteOff),

             (dwDeltaTime: Dur16th; dwStreamID: 0; dwEvent: HiHatOff),

             (dwDeltaTime: Dur16th; dwStreamID: 0; dwEvent: SnareOff)

         );

 

     DrumNOPDummy: array [0..1] of TMIDIEvent =

         (

             (dwDeltaTime: 0; dwStreamID: 0; dwEvent: DummyNoteOn),

             (dwDeltaTime: Dur16th; dwStreamID: 0; dwEvent: 

DummyNoteOff)

         );

 

     DrumNOP: TMIDIEvent =

         (

             dwDeltaTime: Dur16th; dwStreamID: 0; dwEvent: MEVT_NOP 

shl 24

         );

 

     DrumTable: array [1..16] of TDrumEvent =

         (

             (lpData: @Drum1; size: sizeof(Drum1)),

             (lpData: @DrumNOP; size: sizeof(DrumNOP)),

             (lpData: @Drum2; size: sizeof(Drum2)),

             (lpData: @DrumNOP; size: sizeof(DrumNOP)),

             (lpData: @Drum3; size: sizeof(Drum1)),

             (lpData: @DrumNOP; size: sizeof(DrumNOP)),

             (lpData: @Drum2; size: sizeof(Drum2)),

             (lpData: @DrumNOP; size: sizeof(DrumNOP)),

             (lpData: @Drum1; size: sizeof(Drum1)),

             (lpData: @DrumNOP; size: sizeof(DrumNOP)),

             (lpData: @Drum2; size: sizeof(Drum2)),

             (lpData: @DrumNOP; size: sizeof(DrumNOP)),

             (lpData: @Drum3; size: sizeof(Drum1)),

             (lpData: @DrumNOP; size: sizeof(DrumNOP)),

             (lpData: @Drum2; size: sizeof(Drum2)),

             (lpData: @DrumNOP; size: sizeof(DrumNOP))

         );

 

type

   TMainForm = class(TForm)

     PlayBtn: TButton;

     StopBtn: TButton;

     procedure FormCreate(Sender: TObject);

     procedure FormDestroy(Sender: TObject);

     procedure PlayBtnClick(Sender: TObject);

     procedure StopBtnClick(Sender: TObject);

   private

     { Private declarations }

     procedure MOMDONE(var msg: TMessage); message MM_MOM_DONE;

   public

     { Public declarations }

     stream: HMIDISTRM;

     header: TMIDIHDR;

     note: integer;

   end;

 

var

   MainForm: TMainForm;

 

implementation

 

{$R *.DFM}

 

procedure Check(status: MMResult);

begin

     if status <> MMSYSERR_NOERROR then

         MessageDlg('MIDI Stream error: ' + IntToStr(status), mtError, [mbOK], 0);

end;

 

procedure TMainForm.MOMDONE(var msg: TMessage);

begin

     Check(midiOutUnprepareHeader(stream, @header, sizeof(TMIDIHDR)));

     header.lpData := DrumTable[note].lpData;

     header.dwBufferLength := DrumTable[note].size;

     header.dwBytesRecorded := DrumTable[note].size;

     Check(midiOutPrepareHeader(stream, @header, sizeof(TMIDIHDR)));

     Check(midiStreamOut(stream, @header, sizeof(TMIDIHDR)));

     inc(note);

     if note > 16 then note := 1;

end;

 

procedure TMainForm.FormCreate(Sender: TObject);

var

     device: integer;

     timediv: TMIDIPROPTIMEDIV;

     tempo: TMIDIPROPTEMPO;

begin

     device := 0;

     Check(midiStreamOpen(@stream, @device, 1, Handle, 0, CALLBACK_WINDOW));

     timediv.cbStruct := sizeof(TMIDIPROPTIMEDIV);

     timediv.dwTimeDiv := PPQN;

     Check(midiStreamProperty(stream, @timediv, MIDIPROP_SET or MIDIPROP_TIMEDIV));

     tempo.cbStruct := sizeof(TMIDIPROPTEMPO);

     tempo.dwTempo := $0007A120;

     Check(midiStreamProperty(stream, @tempo, MIDIPROP_SET or MIDIPROP_TEMPO));

end;

 

procedure TMainForm.FormDestroy(Sender: TObject);

begin

     Check(midiStreamClose(stream));

end;

 

procedure TMainForm.PlayBtnClick(Sender: TObject);

begin

     note := 1;

     header.lpData := DrumTable[note].lpData;

     header.dwBufferLength := DrumTable[note].size;

     header.dwBytesRecorded := DrumTable[note].size;

     Check(midiOutPrepareHeader(stream, @header, sizeof(TMIDIHDR)));

     Check(midiStreamOut(stream, @header, sizeof(TMIDIHDR)));

     Check(midiStreamRestart(stream));

     inc(note);

end;

 

procedure TMainForm.StopBtnClick(Sender: TObject);

begin

     Check(midiStreamStop(stream));

     Check(midiOutUnprepareHeader(stream, @header, sizeof(TMIDIHDR)));

end;

 

end.

object MainForm: TMainForm

   Left = 193

   Top = 114

   Width = 378

   Height = 147

   Caption = 'MIDI Streaming sample'

   Color = clBtnFace

   Font.Charset = DEFAULT_CHARSET

   Font.Color = clWindowText

   Font.Height = -11

   Font.Name = 'MS Sans Serif'

   Font.Style = []

   OldCreateOrder = False

   Position = poDefaultPosOnly

   OnCreate = FormCreate

   OnDestroy = FormDestroy

   PixelsPerInch = 96

   TextHeight = 13

   object PlayBtn: TButton

     Left = 8

     Top = 8

     Width = 75

     Height = 25

     Caption = '&Play'

     TabOrder = 0

     OnClick = PlayBtnClick

   end

   object StopBtn: TButton

     Left = 112

     Top = 8

     Width = 75

     Height = 25

     Caption = '&Stop'

     TabOrder = 1

     OnClick = StopBtnClick

   end

end