cmpmididata.pas

Delphi的另一款钢琴软件

(*===========================================================================*
 | Midi Data Component for Delphi 3.0                                        |
 |                                                                           |
 | Copyright (c) Colin Wilson 1996-1997.  All rights reserved.               |
 |                                                                           |
 | Version  Date      By    Description                                      |
 | -------  --------  ----  -------------------------------------------------|
 | 1.5      19/2/97   CPWW  Original                                         |
 | 1.51     14/9/97   CPWW  Fixed bug with track name                        |
 | 1.6      11/11/97  CPWW  Riff file reading added                          |
 | 1.7      21/2/98   CPWW  Revised track handling                           |
 *===========================================================================*)

unit cmpMidiData;

interface

uses
  Windows, Messages, SysUtils, Classes, unitMidiGlobals, unitMidiTrackStream;

type
//---------------------------------------------------------------------------
// Type for 'FindEvent'
//   feFirst = find first event at position
//   feLast  = find last event at position
//   feAny   = find any event at position

  SwappedWord = word;

//---------------------------------------------------------------------------
// Midi Data component.
  TMidiData = class(TComponent)
  private
    fTrackList : TList;
    fFileName : string;                   // File (full path) name.
    fHeaderExtra : PChar;                 // Extra bytes from midi file header
    fHeaderExtraSize : LongInt;
    fChanges : boolean;                   // 'Data has changed' flag
    fActive : boolean;                    // True if the data is valid.

    fHeader : packed record               // Midi file header
      format : SwappedWord;
      nTracks : SwappedWord;
      ppqn : SwappedWord;
    end;

    fRiffFlag : boolean;

// Helper functions for properties...

    procedure SetActive (value : boolean);

    function GetPPQN : Integer;           // Unscrambles it from the header
    procedure SetPPQN (value : Integer);

    function GetNoTracks : Integer;       //     "        "   "    "   "

    function GetFileType : Integer;       // Unscrambles it from the 'format' field of the header

    function GetTrack (i : Integer) : TMidiTrackStream;
    function GetShortFileName : string;
    function GetChanges : boolean;
    procedure ClearChanges;


  protected
    procedure ReadHeader (f : TStream);
    procedure ReadTracks (f : TStream);
    procedure WriteHeader (f : TStream);
    procedure WriteTracks ( f : TStream);
    procedure Close;
    procedure Open;

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

    procedure New;
    procedure Save;

    property HeaderExtra : PChar read fHeaderExtra;
    property HeaderExtraSize : LongInt read fHeaderExtraSize;

    procedure SetHeaderExtra (value : PChar; size : LongInt);
    procedure RemoveTrack (idx : Integer);
    procedure EraseTrack (idx : Integer);
    function AddNewTrack (i : Integer) : boolean;

    procedure LoadFromStream (data : TStream);

    property NoTracks : Integer read GetNoTracks;
    property FileType : Integer read GetFileType;
    property Changes : boolean read GetChanges;
    property Tracks [index : Integer] : TMidiTrackStream read GetTrack;
    property ShortFileName : string read GetShortFileName;

  published
    property PPQN : Integer read GetPPQN write SetPPQN;
    property FileName : string read fFileName write fFileName;
    property Active : boolean read fActive write SetActive;
  end;

  EMidiData = class (Exception);

implementation

uses cmpriffStream, mmsystem;

(*---------------------------------------------------------------------*
 | constructor TMidiData.Create ();                                    |
 |                                                                     |
 | Create a MidiData component.                                        |
 |                                                                     |
 | Parameters:                                                         |
 |   AOwner : TComponent        // Component's owner                   |
 *---------------------------------------------------------------------*)
constructor TMidiData.Create (AOwner : TComponent);
begin
  inherited Create (AOwner);
  fTrackList := TList.Create;
  fHeader.ppqn := swap (180);        // Set default header record.
  fHeader.format := swap (1);
end;

(*---------------------------------------------------------------------*
 | destructor TMidiData.Destroy;                                       |
 |                                                                     |
 | Delete the data first.                                              |
 *---------------------------------------------------------------------*)
destructor TMidiData.Destroy;
begin
  Close;
  fTrackList.Free;
  inherited Destroy;
end;

(*---------------------------------------------------------------------*
 | procedure TMidiData.SetActive ();
 |                                                                     |
 | Activate or deactivate the data.  Load the file if it's being       |
 | activated.  Destroy the data if it's being deactivated.             |
 |                                                                     |
 | Parameters:                                                         |
 |   value : boolean       // New 'active' state.                      |
 *---------------------------------------------------------------------*)
procedure TMidiData.SetActive (value : boolean);
begin
  if value <> fActive then
  begin
    case value of
      True :
        if FileName = '' then
          New                          // Initialise new data
        else
          Open;                        // Load the data
      False :
        Close;                         // Delete the data
    end
  end
end;

(*---------------------------------------------------------------------*
 | procedure TMidiData.SetHeaderExtra ();                              |
 |                                                                     |
 | Set extra data in MIDI header rec.                                  |
 |                                                                     |
 | Parameters:                                                         |
 |   value : PChar;                  // The extra data                 |
 |   size : LongInt                  // Size of extra data.            |
 *---------------------------------------------------------------------*)
procedure TMidiData.SetHeaderExtra (value : PChar; size : LongInt);
begin
  if fHeaderExtra <> Nil then        // Free the old extra data
    FreeMem (fHeaderExtra);

  if (value <> Nil) and (size > 0) then
  begin
    fHeaderExtraSize := size;        // Save the data.
    GetMem (fHeaderExtra, size);
    Move (value^, fHeaderExtra^, size);
  end
  else
  begin
    fHeaderExtra := Nil;             // No data to save
    fHeaderExtraSize := 0
  end;
  fChanges := True;
end;

(*---------------------------------------------------------------------*
 | function TMidiData.GetPPQN : Integer;                               |
 |                                                                     |
 | Get resolution of data in PPQN (ticks per crochet)                  |
 |                                                                     |
 | The function returns the resolution.                                |
 *---------------------------------------------------------------------*)
function TMidiData.GetPPQN : Integer;
begin
  result := Swap (fHeader.ppqn);
end;

(*---------------------------------------------------------------------*
 | procedure TMidiData.SetPPQN ();                                     |
 |                                                                     |
 | Set the resolution of the data in PPQN (ticks per crochet)          |
 |                                                                     |
 | Parameters:                                                         |
 |   value : Integer                 // The new resoltuion             |
 *---------------------------------------------------------------------*)
procedure TMidiData.SetPPQN (value : Integer);
begin
  if value <> Swap (fHeader.ppqn) then
  begin
    fHeader.ppqn := Swap (value);
    fChanges := True
  end
end;

(*---------------------------------------------------------------------*
 | function TMidiData.GetNoTracks : Integer;                           |
 |                                                                     |
 | Get the number of tracks                                            |
 |                                                                     |
 | The function returns the number of tracks.                          |
 *---------------------------------------------------------------------*)
function TMidiData.GetNoTracks : Integer;
begin
  result := fTrackList.Count
end;

(*---------------------------------------------------------------------*
 | function TMidiData.GetFileType : Integer;                           |
 |                                                                     |
 | Get the file type only file type 1 is supported.                    |
 |                                                                     |
 | The function returns the file type.                                 |
 *---------------------------------------------------------------------*)
function TMidiData.GetFileType : Integer;
begin
  result := Swap (fHeader.format);
end;

(*---------------------------------------------------------------------*
 | procedure TMidiData.Close;                                          |
 |                                                                     |
 | Deletes the midi data.  This can cause data logss.  Check the       |
 | Changes property before calling...                                  |
 *---------------------------------------------------------------------*)
procedure TMidiData.Close;
var i : Integer;
begin
  if fHeaderExtra <> Nil then        // Free the extra header info.
  begin
    FreeMem (fHeaderExtra);
    fheaderExtra := Nil
  end;

  for i := 0 to fTrackList.Count - 1 do
    TObject (fTrackList [i]).Free;

  fTrackList.Clear;
                                     // Free the tracks.

                                     // Re-initialise the MIDI header.
  fHeader.ppqn := swap (180);
  fHeader.format := swap (1);
  fHeader.nTracks := swap (0);
  ClearChanges;                      // Clear the changes flag, and make the
  fActive := False                   // data inactive.
end;

(*---------------------------------------------------------------------*
 | procedure TMidiData.Open;                                           |
 |                                                                     |
 | Load the MIDI data.                                                 |
 *---------------------------------------------------------------------*)
procedure TMidiData.Open;
var
  f : TStream;
  ext : string;
  p : Integer;
begin
  Close;
  ext := UpperCase (ExtractFileExt (FileName));
  fRiffFlag := (ext = '.RMI') or (ext = '.RIFF');
  if fRiffFlag then
  begin
    f := TRiffFileStream.Create (FileName, fmOpenRead or fmShareDenyWrite);
    with TRiffStream (f) do
    begin
      Descend ('RMID', MMIO_FINDRIFF);
      Descend ('data', MMIO_FINDCHUNK);
    end
  end
  else
  f := TFileStream.Create (FileName, fmOpenRead or fmShareDenyWrite);
  try
    ReadHeader (f);                  // Read the track header
    try
      ReadTracks (f);
      fActive := True;

      if fRiffFlag then     // Always convert to MIDI file for now...
      begin
        p := Pos ('.', FileName);
        if p > 0 then fFileName [p] := #0;
        FileName := PChar (FileName);
        FileName := FileName + '.MID'
      end;


    except                           // We may have allocated memory.  Free it
      Close;                          // with Close
      raise                          // Re-raise the exception