{ Load a midifile and get access to tracks and events I did build this component to convert midifiles to wave files or play the files on a software synthesizer which I'm currenly building. version 1.0 first release version 1.1 added some function function KeyToStr(key : integer) : string; function MyTimeToStr(val : integer) : string; Bpm can be set to change speed version 1.2 added some functions function GetTrackLength:integer; function Ready: boolean; version 1.3 update by Chulwoong, He knows how to use the MM timer, the timing is much better now, thank you for comments/bugs F.Bouwmans fbouwmans@spiditel.nl if you think this component is nice and you use it, sent me a short email. I've seen that other of my components have been downloaded a lot, but I've got no clue wether they are actually used. Don't worry because you are free to use these components Timing has improved, however because the messages are handled by the normal windows message loop (of the main window) it is still influenced by actions done on the window (minimize/maximize ..). Use of a second thread with higher priority which only handles the timer message should increase performance. If somebody knows such a component which is freeware please let me know. interface description: procedure ReadFile: actually read the file which is set in Filename function GetTrack(index: integer) : TMidiTrack; property Filename set/read filename of midifile property NumberOfTracks read number of tracks in current file property TicksPerQuarter: integer ticks per quarter, tells how to interpret the time value in midi events property FileFormat: TFileFormat tells the format of the current midifile property Bpm:integer tells Beats per minut property OnMidiEvent:TOnMidiEvent called while playing for each midi event procedure StartPlaying; start playing the current loaded midifile from the beginning procedure StopPlaying; stop playing the current midifile procedure PlayToTime(time : integer); if playing yourself then events from last time to this time are produced function KeyToStr(key : integer) : string; give note string on key value: e.g. C4 function MyTimeToStr(val : integer) : string; give time string from msec time function GetTrackLength:integer; gives the track lenght in msec (assuming the bpm at the start oof the file) function Ready: boolean; now you can check wether the playback is finished } unit MidiFile; interface {$IFDEF FPC} {$MODE Delphi} {$H+} // use long strings {$ENDIF} uses Windows, Messages, Classes, {$IFDEF FPC} WinAllocation, {$ENDIF} SysUtils, UPath; type TChunkType = (illegal, header, track); TFileFormat = (single, multi_synch, multi_asynch); PByte = ^byte; TMidiEvent = record event: byte; data1: byte; data2: byte; str: string; dticks: integer; time: integer; mtime: integer; len: integer; end; PMidiEvent = ^TMidiEvent; TOnMidiEvent = procedure(event: PMidiEvent) of object; TEvent = procedure of object; TMidiTrack = class(TObject) protected events: TList; name: string; instrument: string; currentTime: integer; currentPos: integer; ready: boolean; trackLenght: integer; procedure checkReady; public OnMidiEvent: TOnMidiEvent; OnTrackReady: TEvent; constructor Create; destructor Destroy; override; procedure Rewind(pos: integer); procedure PlayUntil(pos: integer); procedure GoUntil(pos: integer); procedure putEvent(event: PMidiEvent); function getEvent(index: integer): PMidiEvent; function getName: string; function getInstrument: string; function getEventCount: integer; function getCurrentTime: integer; function getTrackLength: integer; function isReady:boolean; end; TMidiFile = class(TComponent) private { Private declarations } procedure MidiTimer(sender : TObject); procedure WndProc(var Msg : TMessage); protected { Protected declarations } MidiFile: TBinaryFileStream; chunkType: TChunkType; chunkLength: integer; chunkData: PByte; chunkIndex: PByte; chunkEnd: PByte; FPriority: dword; // midi file attributes FFileFormat: TFileFormat; numberTracks: integer; deltaTicks: integer; FBpm: integer; FBeatsPerMeasure: integer; FusPerTick: double; FFilename: IPath; Tracks: TList; currentTrack: TMidiTrack; FOnMidiEvent: TOnMidiEvent; FOnUpdateEvent: TNotifyEvent; // playing attributes playing: boolean; PlayStartTime: integer; currentTime: integer; // Current playtime in msec currentPos: Double; // Current Position in ticks procedure OnTrackReady; procedure SetFilename(val: IPath); procedure ReadChunkHeader; procedure ReadChunkContent; procedure ReadChunk; procedure ProcessHeaderChunk; procedure ProcessTrackChunk; function ReadVarLength: integer; function ReadString(l: integer): string; procedure SetOnMidiEvent(handler: TOnMidiEvent); procedure SetBpm(val: integer); public { Public declarations } constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure ReadFile; function GetTrack(index: integer): TMidiTrack; procedure StartPlaying; procedure StopPlaying; procedure ContinuePlaying; procedure PlayToTime(time: integer); procedure GoToTime(time: integer); function GetCurrentTime: integer; function GetFusPerTick : Double; function GetTrackLength:integer; function Ready: boolean; published { Published declarations } property Filename: IPath read FFilename write SetFilename; property NumberOfTracks: integer read numberTracks; property TicksPerQuarter: integer read deltaTicks; property FileFormat: TFileFormat read FFileFormat; property Bpm: integer read FBpm write SetBpm; property OnMidiEvent: TOnMidiEvent read FOnMidiEvent write SetOnMidiEvent; property OnUpdateEvent: TNotifyEvent read FOnUpdateEvent write FOnUpdateEvent; end; function KeyToStr(key: integer): string; function MyTimeToStr(val: integer): string; procedure Register; implementation uses mmsystem; type {$IFDEF FPC} TTimerProc = TTIMECALLBACK; TTimeCaps = TIMECAPS; {$ELSE} TTimerProc = TFNTimeCallBack; {$ENDIF} const TIMER_RESOLUTION = 10; WM_MULTIMEDIA_TIMER = WM_USER + 127; var MidiFileHandle: HWND; TimerProc: TTimerProc; MidiTimerID: integer; TimerPeriod: integer; procedure TimerCallBackProc(uTimerID, uMsg: Cardinal; dwUser, dwParam1, dwParam2:dword);stdcall; begin PostMessage(HWND(dwUser), WM_MULTIMEDIA_TIMER, 0, 0); end; procedure SetMidiTimer; var TimeCaps: TTimeCaps; begin timeGetDevCaps(@TimeCaps, SizeOf(TimeCaps)); if TIMER_RESOLUTION < TimeCaps.wPeriodMin then TimerPeriod := TimeCaps.wPeriodMin else if TIMER_RESOLUTION > TimeCaps.wPeriodMax then TimerPeriod := TimeCaps.wPeriodMax else TimerPeriod := TIMER_RESOLUTION; timeBeginPeriod(TimerPeriod); MidiTimerID := timeSetEvent(TimerPeriod, TimerPeriod, TimerProc, dword(MidiFileHandle), TIME_PERIODIC); if MidiTimerID=0 then timeEndPeriod(TimerPeriod); end; procedure KillMidiTimer; begin timeKillEvent(MidiTimerID); timeEndPeriod(TimerPeriod); end; constructor TMidiTrack.Create; begin inherited Create; events := TList.Create; currentTime := 0; currentPos := 0; end; destructor TMidiTrack.Destroy; var i: integer; begin for i := 0 to events.count - 1 do Dispose(PMidiEvent(events.items[i])); events.Free; inherited Destroy; end; procedure TMidiTRack.putEvent(event: PMidiEvent); var command: integer; i: integer; pevent: PMidiEvent; begin if event.event = $FF then begin if event.data1 = 3 then name := event.str; if event.data1 = 4 then instrument := event.str; end; currentTime := currentTime + event.dticks; event.time := currentTime; // for the moment just add dticks event.len := 0; events.add(TObject(event)); command := event.event and $F0; if (command = $80) // note off or ((command = $90) and (event.data2 = 0)) //note on with speed 0 then begin // this is a note off, try to find the accompanion note on command := event.event or $90; i := events.count - 2; while i >= 0 do begin pevent := PMidiEvent(events[i]); if (pevent.event = command) and (pevent.data1 = event.data1) then begin pevent.len := currentTIme - pevent.time; i := 0; event.len := -1; end; dec(i); end; end; end; function TMidiTrack.getName: string; begin result := name; end; function TMidiTrack.getInstrument: string; begin result := instrument; end; function TMiditrack.getEventCount: integer; begin result := events.count; end; function TMiditrack.getEvent(index: integer): PMidiEvent; begin if (index < events.count) and (index >= 0) then result := events[index] else result := nil; end; function TMiditrack.getCurrentTime: integer; begin result := currentTime; end; procedure TMiditrack.Rewind(pos: integer); begin if currentPos = events.count then dec(currentPos); while (currentPos > 0) and (PMidiEvent(events[currentPos]).time > pos) do dec(currentPos); checkReady; end; procedure TMiditrack.PlayUntil(pos: integer); begin if assigned(OnMidiEvent) then while ((currentPos < events.count) and (PMidiEvent(events[currentPos]).time < pos)) do begin OnMidiEvent(PMidiEvent(events[currentPos])); inc(currentPos); end; checkReady; end; procedure TMidiTrack.GoUntil(pos: integer); begin while (currentPos < events.count) and (PMidiEvent(events[currentPos]).time < pos) do inc(currentPos); checkReady; end; procedure TMidiTrack.checkReady; begin if currentPos >= events.count then begin ready := true; if assigned(OnTrackReady) then OnTrackReady; end else ready := false; end; function TMidiTrack.getTrackLength: integer; begin result := PMidiEvent(events[events.count-1]).time end; function TMidiTrack.isReady: boolean; begin result := ready; end; constructor TMidifile.Create(AOwner: TComponent); begin inherited Create(AOWner); MidiFileHandle := AllocateHWnd(WndProc); chunkData := nil; chunkType := illegal; Tracks := TList.Create; TimerProc := @TimerCallBackProc; FPriority := GetPriorityClass(MidiFileHandle); end; destructor TMidifile.Destroy; var i: integer; begin if not (chunkData = nil) then FreeMem(chunkData); for i := 0 to Tracks.Count - 1 do TMidiTrack(Tracks.Items[i]).Free; Tracks.Free; SetPriorityClass(MidiFileHandle, FPriority); if MidiTimerID <> 0 then KillMidiTimer; DeallocateHWnd(MidiFileHandle); inherited Destroy; end; function TMidiFile.GetTrack(index: integer): TMidiTrack; begin result := Tracks.Items[index]; end; procedure TMidifile.SetFilename(val: IPath); begin FFilename := val; // ReadFile; end; procedure TMidifile.SetOnMidiEvent(handler: TOnMidiEvent); var i: integer; begin // if not (FOnMidiEvent = handler) then // begin FOnMidiEvent := handler; for i := 0 to tracks.count - 1 do TMidiTrack(tracks.items[i]).OnMidiEvent := handler; // end; end; {$WARNINGS OFF} procedure TMidifile.MidiTimer(Sender: TObject); begin if playing then begin PlayToTime(GetTickCount - PlayStartTime); if assigned(FOnUpdateEvent) then FOnUpdateEvent(self); end; end; {$WARNINGS ON} procedure TMidifile.StartPlaying; var i: integer; begin for i := 0 to tracks.count - 1 do TMidiTrack(tracks[i]).Rewind(0); playStartTime := getTickCount; playing := true; SetPriorityClass(MidiFileHandle, REALTIME_PRIORITY_CLASS); SetMidiTimer; currentPos := 0.0; currentTime := 0; end; {$WARNINGS OFF} procedure TMidifile.ContinuePlaying; begin PlayStartTime := GetTickCount - currentTime; playing := true; SetPriorityClass(MidiFileHandle, REALTIME_PRIORITY_CLASS); SetMidiTimer; end; {$WARNINGS ON} procedure TMidifile.StopPlaying; begin playing := false; KillMidiTimer; SetPriorityClass(MidiFileHandle, FPriority); end; function TMidiFile.GetCurrentTime: integer; begin Result := currentTime; end; procedure TMidifile.PlayToTime(time: integer); var i: integer; track: TMidiTrack; pos: integer; deltaTime: integer; begin // calculate the pos in the file. // pos is actually tick // Current FusPerTick is uses to determine the actual pos deltaTime := time - currentTime; currentPos := currentPos + (deltaTime * 1000) / FusPerTick; pos := round(currentPos); for i := 0 to tracks.count - 1 do begin TMidiTrack(tracks.items[i]).PlayUntil(pos); end; currentTime := time; end; procedure TMidifile.GoToTime(time: integer); var i: integer; track: TMidiTrack; pos: integer; begin // this function should be changed because FusPerTick might not be constant pos := round((time * 1000) / FusPerTick); for i := 0 to tracks.count - 1 do begin TMidiTrack(tracks.items[i]).Rewind(0); TMidiTrack(tracks.items[i]).GoUntil(pos); end; end; procedure TMidifile.SetBpm(val: integer); var us_per_quarter: integer; begin if not (val = FBpm) then begin us_per_quarter := 60000000 div val; FBpm := 60000000 div us_per_quarter; FusPerTick := us_per_quarter / deltaTicks; end; end; procedure TMidifile.ReadChunkHeader; var theByte: array[0..7] of byte; begin MidiFile.Read(theByte[0], 8); if (theByte[0] = $4D) and (theByte[1] = $54) then begin if (theByte[2] = $68) and (theByte[3] = $64) then chunkType := header else if (theByte[2] = $72) and (theByte[3] = $6B) then chunkType := track else chunkType := illegal; end else chunkType := illegal; chunkLength := theByte[7] + theByte[6] * $100 + theByte[5] * $10000 + theByte[4] * $1000000; end; procedure TMidifile.ReadChunkContent; begin if not (chunkData = nil) then FreeMem(chunkData); GetMem(chunkData, chunkLength + 10); MidiFile.Read(chunkData^, chunkLength); chunkIndex := chunkData; chunkEnd := PByte(integer(chunkIndex) + integer(chunkLength) - 1); end; procedure TMidifile.ReadChunk; begin ReadChunkHeader; ReadChunkContent; case chunkType of header: ProcessHeaderChunk; track: ProcessTrackCHunk; end; end; procedure TMidifile.ProcessHeaderChunk; begin chunkIndex := chunkData; inc(chunkIndex); if chunkType = header then begin case chunkIndex^ of 0: FfileFormat := single; 1: FfileFormat := multi_synch; 2: FfileFormat := multi_asynch; end; inc(chunkIndex); numberTracks := chunkIndex^ * $100; inc(chunkIndex); numberTracks := numberTracks + chunkIndex^; inc(chunkIndex); deltaTicks := chunkIndex^ * $100; inc(chunkIndex); deltaTicks := deltaTicks + chunkIndex^; end; end; procedure TMidifile.ProcessTrackChunk; var dTime: integer; event: integer; len: integer; str: string; midiEvent: PMidiEvent; i: integer; us_per_quarter: integer; begin chunkIndex := chunkData; // inc(chunkIndex); event := 0; if chunkType = track then begin currentTrack := TMidiTrack.Create; currentTrack.OnMidiEvent := FOnMidiEvent; Tracks.add(currentTrack); while integer(chunkIndex) < integer(chunkEnd) do begin // each event starts with var length delta time dTime := ReadVarLength; if chunkIndex^ >= $80 then begin event := chunkIndex^; inc(chunkIndex); end; // else it is a running status event (just the same event as before) if event = $FF then begin { case chunkIndex^ of $00: // sequence number, not implemented jet begin inc(chunkIndex); // $02 inc(chunkIndex); end; $01 .. $0f: // text events FF ty len text begin New(midiEvent); midiEvent.event := $FF; midiEvent.data1 := chunkIndex^; // type is stored in data1 midiEvent.dticks := dtime; inc(chunkIndex); len := ReadVarLength; midiEvent.str := ReadString(len); currentTrack.putEvent(midiEvent); end; $20: // Midi channel prefix FF 20 01 cc begin inc(chunkIndex); // $01 inc(chunkIndex); // channel inc(chunkIndex); end; $2F: // End of track FF 2F 00 begin inc(chunkIndex); // $00 inc(chunkIndex); end; $51: // Set Tempo FF 51 03 tttttt begin inc(chunkIndex); // $03 inc(chunkIndex); // tt inc(chunkIndex); // tt inc(chunkIndex); // tt inc(chunkIndex); end; $54: // SMPTE offset FF 54 05 hr mn se fr ff begin inc(chunkIndex); // $05 inc(chunkIndex); // hr inc(chunkIndex); // mn inc(chunkIndex); // se inc(chunkIndex); // fr inc(chunkIndex); // ff inc(chunkIndex); end; $58: // Time signature FF 58 04 nn dd cc bb begin inc(chunkIndex); // $04 inc(chunkIndex); // nn inc(chunkIndex); // dd inc(chunkIndex); // cc inc(chunkIndex); // bb inc(chunkIndex); end; $59: // Key signature FF 59 02 df mi begin inc(chunkIndex); // $02 inc(chunkIndex); // df inc(chunkIndex); // mi inc(chunkIndex); end; $7F: // Sequence specific Meta-event begin inc(chunkIndex); len := ReadVarLength; str := ReadString(len); end; else // unknown meta event } begin New(midiEvent); midiEvent.event := $FF; midiEvent.data1 := chunkIndex^; // type is stored in data1 midiEvent.dticks := dtime; inc(chunkIndex); len := ReadVarLength; midiEvent.str := ReadString(len); currentTrack.putEvent(midiEvent); case midiEvent.data1 of $51: begin us_per_quarter := (integer(byte(midiEvent.str[1])) shl 16 + integer(byte(midiEvent.str[2])) shl 8 + integer(byte(midiEvent.str[3]))); FBpm := 60000000 div us_per_quarter; FusPerTick := us_per_quarter / deltaTicks; end; end; end; // end; end else begin // these are all midi events New(midiEvent); midiEvent.event := event; midiEvent.dticks := dtime; // inc(chunkIndex); case event of $80..$8F, // note off $90..$9F, // note on $A0..$AF, // key aftertouch $B0..$BF, // control change $E0..$EF: // pitch wheel change begin midiEvent.data1 := chunkIndex^; inc(chunkIndex); midiEvent.data2 := chunkIndex^; inc(chunkIndex); end; $C0..$CF, // program change $D0..$DF: // channel aftertouch begin midiEvent.data1 := chunkIndex^; inc(chunkIndex); end; else // error end; currentTrack.putEvent(midiEvent); end; end; end; end; function TMidifile.ReadVarLength: integer; var i: integer; b: byte; begin b := 128; i := 0; while b > 127 do begin i := i shl 7; b := chunkIndex^; i := i + b and $7F; inc(chunkIndex); end; result := i; end; function TMidifile.ReadString(l: integer): string; var s: Pchar; i: integer; begin GetMem(s, l + 1); ; s[l] := chr(0); for i := 0 to l - 1 do begin s[i] := Chr(chunkIndex^); inc(chunkIndex); end; result := string(s); end; procedure TMidifile.ReadFile; var i: integer; begin for i := 0 to Tracks.Count - 1 do TMidiTrack(Tracks.Items[i]).Free; Tracks.Clear; chunkType := illegal; MidiFile := TBinaryFileStream.Create(FFilename, fmOpenRead); while (MidiFile.Position < MidiFile.Size) do ReadChunk; FreeAndNil(MidiFile); numberTracks := Tracks.Count; end; function KeyToStr(key: integer): string; var n: integer; str: string; begin n := key mod 12; case n of 0: str := 'C'; 1: str := 'C#'; 2: str := 'D'; 3: str := 'D#'; 4: str := 'E'; 5: str := 'F'; 6: str := 'F#'; 7: str := 'G'; 8: str := 'G#'; 9: str := 'A'; 10: str := 'A#'; 11: str := 'B'; end; Result := str + IntToStr(key div 12); end; function IntToLenStr(val: integer; len: integer): string; var str: string; begin str := IntToStr(val); while Length(str) < len do str := '0' + str; Result := str; end; function MyTimeToStr(val: integer): string; var hour: integer; min: integer; sec: integer; msec: integer; begin msec := val mod 1000; sec := val div 1000; min := sec div 60; sec := sec mod 60; hour := min div 60; min := min mod 60; Result := IntToStr(hour) + ':' + IntToLenStr(min, 2) + ':' + IntToLenStr(sec, 2) + '.' + IntToLenStr(msec, 3); end; function TMidiFIle.GetFusPerTick : Double; begin Result := FusPerTick; end; function TMidiFIle.GetTrackLength:integer; var i, length: integer; time: extended; begin length := 0; for i := 0 to Tracks.Count - 1 do if TMidiTrack(Tracks.Items[i]).getTrackLength > length then length := TMidiTrack(Tracks.Items[i]).getTrackLength; time := length * FusPerTick; time := time / 1000.0; result := round(time); end; function TMidiFIle.Ready: boolean; var i : integer; begin result := true; for i := 0 to Tracks.Count - 1 do if not TMidiTrack(Tracks.Items[i]).isready then result := false; end; procedure TMidiFile.OnTrackReady; begin if ready then if assigned(FOnUpdateEvent) then FOnUpdateEvent(self); end; procedure TMidiFile.WndProc(var Msg : TMessage); begin with Msg do begin case Msg of WM_MULTIMEDIA_TIMER: begin //try MidiTimer(self); //except // Note: HandleException() is called by default if exception is not handled // Application.HandleException(Self); //end; end; else begin Result := DefWindowProc(MidiFileHandle, Msg, wParam, lParam); end; end; end; end; procedure Register; begin RegisterComponents('Synth', [TMidiFile]); end; end.