midigen.pas

TMidiGen is a MIDI component by Alan Warriner which allows the simple creation of sound effects and

unit MidiGen;

interface

uses
  Windows, Messages, SysUtils, Classes,mmsystem,forms;


//*************************************************************
//TMidiGen

const
     //default values
     VolumeDef=100;
     ChorusDef=0;
     ReverbDef=0;
     SustainDef=false;
     PanDef=0;
     PBDef=0;
     PBDelayDef=0;
     PBDurationDef=100;
     DurationDef=50;
     OctaveDef=4;
     NoteDef=0;
     ModulationDef=0;
     InstrumentDef=0;
     ChannelDef=0;
     LoopsDef=1;

type
  TMGPercentage = 0..100;
  //TMGNote= (mg00_C,mg01_Dsharp,mg02_D,mg03_Eb,mg04_E,mg05_F,mg06_Gb,mg07_G,mg08_Ab,mg09_A,mg10_Bb,mg11_B);
  TMGNote= (mgC,mgCsharp,mgD,mgDsharp,mgE,mgF,mgFsharp,mgG,mgGsharp,mgA,mgAsharp,mgB);
  TMGChannel=(mgCh01,mgCh02,mgCh03,mgCh04,mgCh05,mgCh06,mgCh07,mgCh08,mgCh09,mgCh10,mgCh11,mgCh12,mgCh13,mgCh14,mgCh15,mgCh16);
  //instruments (type)
  TMGInstrument=(
  mgAcousticGrandPiano,mgBrightAcousticPiano,mgElectricGrandPiano,
  mgHonkyTonkPiano,mgElectricPiano1,mgElectricPiano2,mgHarpsichord,mgClavinet,
  mgCelesta,mgGlockenspiel,mgMusicBox,mgVibraphone,mgMarimba,mgXylophone,
  mgTubularBells,mgDulcimer,
  mgDrawbarOrgan,mgPercussiveOrgan,mgRockOrgan,mgChurchOrgan,
  mgReedOrgan,mgAccordion,mgHarmonica,mgTangoAccordion,
  mgAcousticNylonGuitar,mgAcousticSteelGuitar,mgJazzElectricGuitar,
  mgCleanElectricGuitar,mgMutedElectricGuitar,mgOverdrivenGuitar,
  mgDistortionGuitar,mgGuitarHarmonics,mgAcousticBass,
  mgFingeredElectricBass,mgPickedElectricBass,mgFretlessBass,
  mgSlapBass1,mgSlapBass2,mgSynthBass1,mgSynthBass2,
  mgViolin,mgViola,mgCello,mgContrabass,
  mgTremoloStrings,mgPizzicatoStrings,mgOrchestralHarp,mgTimpani,
  mgStringEnsemble1,mgStringEnsemble2,mgSynthStrings1,
  mgSynthStrings2,mgChoirAahs,mgVoiceOohs,mgSynthVoice,mgOrchestraHit,
  mgTrumpet,mgTrombone,mgTuba,mgMutedTrumpet,mgFrenchHorn,
  mgBrassSection,mgSynthBrass1,mgSynthBrass2,
  mgSopranoSax,mgAltoSax,mgTenorSax,mgBaritoneSax,
  mgOboe,mgEnglishHorn,mgBassoon,mgClarinet,
  mgPiccolo,mgFlute,mgRecorder,mgPanFlute,mgBlownBottle,
  mgShakuhachi,mgWhistle,mgOcarina,
  mgSquareLead,mgSawtoothLead,mgCalliopeLead,mgChiffLead,
  mgCharangLead,mgVoiceLead,mgFifthsLead,mgBassandLead,
  mgNewAgePad,mgWarmPad,mgPolySynthPad,mgChoirPad,
  mgBowedPad,mgMetallicPad,mgHaloPad,mgSweepPad,
  mgSynthFXRain,mgSynthFXSoundtrack,mgSynthFXCrystal,mgSynthFXAtmosphere,
  mgSynthFXBrightness,mgSynthFXGoblins,mgSynthFXEchoes,mgSynthFXSciFi,
  mgSitar,mgBanjo,mgShamisen,mgKoto,mgKalimba,
  mgBagpipe,mgFiddle,mgShanai,
  mgTinkleBell,mgAgogo,mgSteelDrums,mgWoodblock,
  mgTaikoDrum,mgMelodicTom,mgSynthDrum,mgReverseCymbal,
  mgGuitarFretNoise,mgBreathNoise,mgSeashore,mgBirdTweet,
  mgTelephoneRing,mgHelicopter,mgApplause,mgGunshot,
  //percussion
  mgAcousticBassDrum,mgBassDrum1,mgSideStick,mgAcousticSnare,
  mgHandClap,mgElectricSnare,mgLowFloorTom,mgClosedHiHat,
  mgHighFloorTom,mgPedalHiHat,mgLowTom,mgOpenHiHat,
  mgLowMidTom,mgHiMidTom,mgCrashCymbal1,mgHighTom,
  mgRideCymbal1,mgChineseCymbal,mgRideBell,mgTambourine,
  mgSplashCymbal,mgCowbell,mgCrashCymbal2,mgVibraslap,
  mgRideCymbal2,mgHiBongo,mgLowBongo,mgMuteHiConga,
  mgOpenHiConga,mgLowConga,mgHighTimbale,mgLowTimbale,
  mgHighAgogo,mgLowAgogo,mgCabasa,mgMaracas,
  mgShortWhistle,mgLongWhistle,mgShortGuiro,mgLongGuiro,
  mgClaves,mgHiWoodBlock,mgLowWoodBlock,mgMuteCuica,
  mgOpenCuica,mgMuteTriangle,mgOpenTriangle
  );

  TMidiGen = class(TComponent)

  private
    { Private declarations }
    //midi handle
    OutHandle: HMIDISTRM;
    //midi device
    MidiDevice: UINT;
    //memory handle
    DataBuffer: PChar;
    //buffer size
    BufferSize: Integer;
    //short event count
    sEventCount: Integer;
    //midi header
    mhdr: MIDIHDR;

    //unique ID for each component
    ID:Integer;

    fVolume:Integer;
    fModulation:Integer;
    fChorus:Integer;
    fReverb:Integer;
    fPitchBend:Integer;
    fPBDelay:Integer;
    fPBDuration:Integer;
    fSustain:bool;
    fPan:Integer;
    fNote:TMGNote;
    fOctave:Integer;
    fDuration:Cardinal;
    fInstrument:TMGInstrument;
    fChannel:TMGChannel;
    ChannelInUse:TMGChannel;
    fLoops:Cardinal;
    fIsPlaying:bool;

    CleaningUp:bool;
    DeviceOpened:bool;

    LoopAllowed:bool;
    LoopCount:Cardinal;

    CanPlay:bool;

    TMGHwnd:HWND;

    procedure SetVolume(val:Integer);
    procedure SetReverb(val:Integer);
    procedure SetModulation(val:Integer);
    procedure SetPan(val:Integer);
    procedure SetChorus(val:Integer);
    procedure SetSustain(val:bool);
    procedure SetPitchBend(val:Integer);
    procedure SetPBDelay(val:Integer);
    procedure SetPBDuration(val:Integer);
    procedure SetDuration(val:Cardinal);
    procedure SetNote(val:TMGNote);
    procedure SetOctave(val:Integer);
    procedure SetInstrument(val:TMGInstrument);
    procedure SetChannel(val:TMGChannel);
    procedure SetLoops(val:Cardinal);
    procedure WndProc(var TM: TMessage);

    function LimitValue(lower,upper,val: Integer):Integer;
    function GetPercentage(PC: Integer):Integer;
    function PlayData(ResetOnly:bool; PitchBendEnabled:bool; Data:TList):bool;
    function ExtractNotes(NoteString:String; var Data:TList):bool;
    function WaitForClose: bool;

    class function GetUniqueID: Integer;
    class function IDInUse: Integer;

  protected
    { Protected declarations }

  public
    { Public declarations }

    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;

  published
    { Published declarations }
    property Volume: Integer read fVolume write SetVolume default VolumeDef;
    property Pan: Integer read fPan write SetPan default PanDef;
    property Reverb: Integer read fReverb write SetReverb default ReverbDef;
    property Chorus: Integer read fChorus write SetChorus default ChorusDef;
    property Sustain: bool read fSustain write SetSustain default SustainDef;
    property Modulation: Integer read fModulation write SetModulation default ModulationDef;
    property PitchBend: Integer read fPitchBend write SetPitchBend default PBDef;
    property PBDelay: Integer read fPBDelay write SetPBDelay default PBDelayDef;
    property PBDuration: Integer read fPBDuration write SetPBDuration default PBDurationDef;
    property Duration: Cardinal read fDuration write SetDuration default DurationDef;
    property Note: TMGNote read fNote write SetNote default TMGNote(NoteDef);
    property Octave: Integer read fOctave write SetOctave default OctaveDef;
    property Instrument: TMGInstrument read fInstrument write SetInstrument default TMGInstrument(InstrumentDef);
    property Channel: TMGChannel read fChannel write SetChannel default TMGChannel(ChannelDef);
    property Loops: Cardinal read fLoops write SetLoops default LoopsDef;
    property IsPlaying:bool read fIsPlaying;

    function MidiAvailable:bool;
    function Play:bool;
    function PlayString(Notes:String):bool;
    function PlayNote(NoteVal:Integer):bool;
    function SetDevice(Device:Integer):bool;
    procedure Stop;

  end;

procedure Register;

implementation

//short event types
type sEvent=(sePBRange,seRPNLSB,seRPNMSB,seReverb,seChorus,seSustain,seInstrument,seReset,seNoteOn,seNoteOff,sePitchBend,seVolume,sePan,seModulation);

//midievent short message
type sMIDIEVENT= record
        dwDeltaTime: DWORD;
        dwStreamID: DWORD;
        dwEvent: DWORD;
        end;

//string data contents
type event=record
     dwEventStart:DWORD;
     dwEventType:sEvent;
     dwData:DWORD;
     dwChannel:TMGChannel;
     Processed:bool;
     end;

//forward declarations
function ShortEvent(Time:Integer; lChannel:TMGChannel; Event:SEvent; Data:DWORD;DoCallback:bool=false):sMIDIEVENT;forward;
function NoteOn(Time:Integer; lChannel:TMGChannel; Note:String; Octave:DWORD; Level:Integer):sMIDIEVENT;forward;
function NoteOnDWord(Time:Integer; lChannel:TMGChannel; Note:DWORD; Level:Integer):sMIDIEVENT;forward;
function NoteOff(Time:Integer; lChannel:TMGChannel; Note:String; Octave:DWORD):sMIDIEVENT;forward;
function ResetChannel(Time:Integer; lChannel:TMGChannel;Callback:bool=false):sMIDIEVENT;forward;
function AllNotesOff(Time:Integer; lChannel:TMGChannel):sMIDIEVENT;forward;
function GetNoteNumber(NoteString:String):Integer;forward;
function AddInstrument(Time:Integer; lChannel:TMGChannel; Instrument:TMGInstrument):sMIDIEVENT;forward;
function SetPercussion(Time:Integer; Instrument:DWORD; Level:DWORD; Hit: bool):sMIDIEVENT;forward;
function MidiWord(dw:DWORD):DWORD;forward;
function AddData(Data:PChar; var DataBuf:PChar; var BufSize:Integer; DataSize:Integer):bool;forward;
function AddShortEvent(sEvent:sMIDIEVENT; var DataBuf:PChar; var BufSize:Integer; var EvCount:Integer):bool;forward;
procedure DoPitchBend(TotalTime:Integer; delayPC:Integer; durationPC:Integer; levelPC:Integer; lChannel:TMGChannel; var DataBuf:PChar; var BufSize:Integer; var EvCount:Integer );forward;
function DoReverb(Time:Integer; lChannel:TMGChannel; LevelPC:Integer):sMIDIEVENT;forward;
function DoChorus(Time:Integer; lChannel:TMGChannel; LevelPC:Integer):sMIDIEVENT;forward;
function DoModulation(Time:Integer; lChannel:TMGChannel; LevelPC:Integer):sMIDIEVENT;forward;
function DoVolume(Time:Integer; lChannel:TMGChannel; LevelPC:Integer):sMIDIEVENT;forward;
function DoPan(Time:Integer; lChannel:TMGChannel; LevelPC:Integer):sMIDIEVENT;forward;
function DoSustain(Time:Integer; lChannel:TMGChannel; EffectOn:bool):sMIDIEVENT;forward;
procedure AddChannelEndEvent(lChannel:TMGChannel; var DataBuf:PChar; var BufSize:Integer; var EvCount:Integer);forward;
function EventSort(Item1, Item2: Pointer): Integer;forward;

//procedure dbout(dbstring:String;ok:bool;extra:String='');forward;

var
  //class variables
  UniqueID:Integer=1;
  CurrentID:Integer=0;

  //size of short event structure
  sEventSize: Integer=sizeof(sMIDIEVENT);
  //size of midi header
  HeaderSize: Integer=sizeof(MIDIHDR);
  //note-number string
  NoteNumbers: String='00C01C+01C#02D01D-03D+03D#04E03E-05F06F+06F#07G06G-08G+08G#09A08A-10A+10A#11B10B-';
TotalAlloc:integer;
EventCount:integer;

const
     PERCUSSION=TMGChannel(9);
     LASTINSTRUMENT=174;

procedure Register;
begin
  RegisterComponents('Samples', [TMidiGen]);
end;


//unique ID for each component **********************************************
class function TMidiGen.GetUniqueID: Integer;
begin
Result:=UniqueID;
end;

//current component using midi **********************************************
class function TMidiGen.IDInUse: Integer;
begin
Result:=CurrentID;
end;

//limit value
function TMidiGen.LimitValue(lower,upper,val: Integer):Integer;
var
   msg:String;

begin
if (val>=lower) and (val<=upper) then
   begin
   Result:=val;
   Exit;
   end;

//error message?
if csDesigning in ComponentState then
   begin
   msg:='Value must be between '+IntToStr(lower)+' and '+IntToStr(upper);
   MessageBox(0,PChar(msg),'Error',MB_OK or MB_ICONERROR);
   end;

if val>upper then
   Result:=upper
else
   Result:=lower;


end;


//limit values  0 to 100 **********************************************
//if designing give warning
//force to limits
function TMidiGen.GetPercentage(PC: Integer):Integer;
begin

Result:=LimitValue(0,100,PC);
end;

//constructor **********************************************
constructor TMidiGen.Create(AOwner: TComponent);
begin
Inherited Create(AOwner);

OutHandle:=0;
MidiDevice:=MIDIMAPPER;
DataBuffer:=nil;
BufferSize:=0;
sEventCount:=0;

fLoops:=LoopsDef;
fVolume:=VolumeDef;
fReverb:=ReverbDef;
fChorus:=ChorusDef;
fPan:=PanDef;
fPitchBend:=PBDef;
fPBDelay:=PBDelayDef;
fPBDuration:=PBDurationDef;
fDuration:=DurationDef;
fOctave:=OctaveDef;
fNote:=TMGNote(NoteDef);
fSustain:=SustainDef;
fModulation:=ModulationDef;
fInstrument:=TMGInstrument(InstrumentDef);
fChannel:=TMGChannel(ChannelDef);
ChannelInUse:=fChannel;

CleaningUp:=false;

fIsPlaying:=false;
LoopAllowed:=false;
DeviceOpened:=false;

//unique ID
ID:=GetUniqueID;
inc(UniqueID);

//window handle & proc
TMGHwnd:=AllocateHWnd(WndProc);
TotalAlloc:=0;

//can play
CanPlay:=true;

end;

//destructor **********************************************
destructor TMidiGen.Destroy;
begin
//stop
Stop;

while DeviceOpened do
      Application.ProcessMessages;


DeallocateHWnd(TMGHwnd);

inherited Destroy;
end;

//wndproc **********************************************
procedure TMidiGen.WndProc(var TM: TMessage);
var
   msg:UINT;

begin
msg:=TM.Msg;

//open
if msg=MOM_OPEN then
   begin
   //mdshow('open');
   DeviceOpened:=true;
   fIsPlaying:=true;
   LoopAllowed:=true;
   LoopCount:=fLoops;

   end;

//callback on first event
if (msg=MM_MOM_POSITIONCB) or (msg=MOM_POSITIONCB) then
   begin
   CanPlay:=true;
   end;

if msg=MOM_DONE then
        begin

        //loop?
        if LoopAllowed and ((LoopCount>1) or (LoopCount=0))then
           begin

           //play again?
           if (LoopCount>1) or (LoopCount=0) then
              begin
              midiStreamOut(OutHandle,@mhdr,HeaderSize);
              midiStreamRestart(OutHandle);
              end;

           //dec loop count
           if LoopCount>1 then
              begin
              Dec(LoopCount);
              end;

           Exit;
           end;

        midiOutUnprepareHeader(OutHandle,@mhdr,HeaderSize);

        midiStreamStop(OutHandle);

        midiOutReset(OutHandle);

        if DataBuffer<>nil then
           begin
           GlobalFree(HGLOBAL(DataBuffer));
           Dec(TotalAlloc);

          DataBuffer:=nil;
          BufferSize:=0;
          sEventCount:=0;
          end;

        midiStreamClose(OutHandle);

        end;//MOM_DONE

if msg=MOM_CLOSE then
   begin
   //mdshow('closed');
   DeviceOpened:=false;
   OutHandle:=0;
   fIsPlaying:=false;
   LoopAllowed:=false;
   Inc(EventCount);

   end;

end;

//set device **********************************************
function TMidiGen.SetDevice(Device:Integer):bool;
var
   nd:Integer;

begin
MidiDevice:=Device;

//number of devices
nd:=midiOutGetNumDevs;

//error?
if (nd=0) or (nd<=Device) then
   result:=false
else
   result:=true;

end;


//volume **********************************************
procedure TMidiGen.SetVolume(val:Integer);
begin
fVolume:=GetPercentage(val);
end;

//reverb **********************************************
procedure TMidiGen.SetReverb(val:Integer);
begin
fReverb:=GetPercentage(val);
end;

//pan **********************************************
procedure TMidiGen.SetPan(val:Integer);
begin
fPan:=LimitValue(-100,100,val);
end;

//chorus **********************************************
procedure TMidiGen.SetChorus(val:Integer);
begin
fChorus:=GetPercentage(val);
end;

//sustain **********************************************
procedure TMidiGen.SetSustain(val:bool);
begin
fSustain:=val;
end;

//modulation **********************************************
procedure TMidiGen.SetModulation(val:Integer);
begin
fModulation:=GetPercentage(val);
end;

// pitch bend level **********************************************
procedure TMidiGen.SetPitchBend(val:Integer);
begin
fPitchBend:=LimitValue(-120,120,val);
end;

// pitch bend delay **********************************************
procedure TMidiGen.SetPBDelay(val:Integer);
begin
fPBDelay:=GetPercentage(val);
end;

// pitch bend duration **********************************************
procedure TMidiGen.SetPBDuration(val:Integer);
begin
fPBDuration:=GetPercentage(val);
end;

//duration **********************************************
procedure TMidiGen.SetDuration(val:Cardinal);
begin
fDuration:=val;
end;

//note **********************************************
procedure TMidiGen.SetNote(val:TMGNote);
begin
fNote:=TMGNote(LimitValue(0,11,Integer(val)));
end;

//octave **********************************************
procedure TMidiGen.SetOctave(val:Integer);
begin
fOctave:=LimitValue(0,10,val);
end;

//instrument **********************************************
procedure TMidiGen.SetInstrument(val:TMGInstrument);
begin
fInstrument:=TMGInstrument(LimitValue(0,LASTINSTRUMENT,Integer(val)));
end;

//channel **********************************************
procedure TMidiGen.SetChannel(val:TMGChannel);
begin

fChannel:=TMGChannel(LimitValue(0,15,Integer(val)));

end;

//loops **********************************************
procedure TMidiGen.SetLoops(val:Cardinal);
begin
fLoops:=val;
end;

//----------------------------------------------------------------------------
//midi callback
procedure MidiProc(hmo:HMIDIOUT; msg:UINT; inst:DWORD; param1:DWORD; param2:DWORD);stdcall;
var
   passed:TMidiGen;