cmpmidioutput.pas

Delphi的另一款钢琴软件

unit cmpMidiOutput;

(*===========================================================================*
 | Midi Output Component for Delphi 3.0                                      |
 |                                                                           |
 | Copyright (c) Colin Wilson 1996.  All rights reserved.                    |
 |                                                                           |
 | nb.  Caches output ports, so the same port can be opened more than once.  |
 |                                                                           |
 | Version  Date      By    Description                                      |
 | -------  --------  ----  -------------------------------------------------|
 | 1.0      26/8/96   CPWW  Original                                         |
 | 1.01     27/1/98   CPWW  Fixed bug in 'AllNotesOff'.  Better Controller   |
 |                          defaults.  (Thanks to Remko Kramer)              |
 *===========================================================================*)

interface

uses
  Windows, Messages, SysUtils, Classes, Forms, MMSystem, cmpInstrument, unitMidiGlobals;

const

//-------------------------------------------------------------------------
// Default values for controllers...
 ControllerDefaults : array [TController] of Integer = (
   0, 0, 0, 0, 0, 0, 0, 90 {Volume} , 0, 0, 64 {Pan }, 127 {Expression}, 0, 0, 0, 0,
   0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
   0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
   0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
   0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
   0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 40, 0, 0, 0, 0,
   0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
   0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0
 );

type

TMidiOutputPort = class;

TPhysicalOutputPort = class
private
  Handle : HMIDIOUT;
  PortID : Integer;
  PortNo : Integer;       // Index in port list
  UserList : TList;
  CurrentBank : array [TChannel] of TBankNo;
  CurrentPatch : array [TChannel] of TPatchNo;
  ControllerArray : array [TChannel, TController] of Integer;
  procedure ResetControllers;
  procedure PatchChange (bank : TBankNo; patch : TPatchNo; channel : TChannel);

  constructor Create (pID : Integer; user : TMidiOutputPort);
  procedure RemoveUser (user : TMidiOutputPort);
  procedure AddUser (user : TMidiOutputPort);
  public
  destructor Destroy; override;
end;

(*--------------------------------------------------------------------------*
 | TMidiOutputPort.                                                         |
 |                                                                          |
 | A virtual MIDI output port.                                              |
 |                                                                          |
 | Properties:                                                              |
 |  (published) property PortId : Integer  // The MIDI port number          |
 |  (published) property Active : boolean  // Turns on or off the port.     |
 |  (public)    property Handle : HMIDIOUT // (ro) - The port handle        |
 |                                                                          |
 | Methods:                                                                 |
 |   (public) procedure OutEvent (const Event : TEventData);                |
 |   (   "  ) AllNotesOff;                                                  |
 |   (   "  ) procedure ResetControllers;                                   |
 |                                                                          |
 |                                                                          |
 |    (prot ) procedure midiOutCallback (uMsg : UINT; dw1, dw2 : LongInt);  |
 |            virtual;                                                      |
 *--------------------------------------------------------------------------*)

  TMidiOutputPort = class(TComponent)
  private
    fPortID : Integer;
    fPhysicalPort : TPhysicalOutputPort;
    fSysexHeaders : TList;

    userNo : Integer;

    NoteArray : array [TChannel, TNote] of Integer;
    fSysexLatency: Integer;

    procedure SetPortId (value : Integer);
    procedure SetActive (value : boolean);
    function getActive : boolean;
    function GetHandle : HMidiOut;
    procedure TidySysexHeaders;

  protected
    procedure midiOutCallback (uMsg : UINT; dw1, dw2 : LongInt); virtual;
    { Protected declarations }
  public
    constructor Create (AOwner : TComponent); override;
    destructor Destroy; override;
    property Handle : HMIDIOUT read GetHandle;
    procedure OutSysex (data : PChar; len : word);
    procedure OutEvent (const Event : TEventData);
    procedure AllNotesOff;
    procedure ResetControllers;
    function GetPatch (bank : TBankNo; Patch : TPatchNo) : TPatch;
    procedure PatchChange (bank : TBankNo; patch : TPatchNo; channel : TChannel);
    procedure NoteOn (channel, note, velocity : Integer);
    procedure NoteOff (channel, note, velocity : Integer);
    procedure WaitForSysex;

  published
    property PortId : Integer read fPortID write SetPortId;
    property Active : boolean read GetActive write SetActive;
    property SysexLatency : Integer read fSysexLatency write fSysexLatency default 50;
  end;

  EMidiOutputPort = class (Exception);

procedure SetOutputPrtInstrument (id : Integer; instrument : TInstrument);

implementation

var
  PortList : TList;
  instrumentCache : array [0..7] of TInstrument;

procedure SetOutputPrtInstrument (id : Integer; instrument : TInstrument);
begin
  instrumentCache [id] := instrument;
end;

procedure MidiOutCallback (handle : HMIDIOUT; uMsg : UINT; dwUser, dw1, dw2 : DWORD); stdcall;
var
  portNo, userNo : word;
  port : TPhysicalOutputPort;
  instance : TMidiOutputPort;
begin
  portNo := LoWord (dwUser);
  userNo := HiWord (dwUser);
  port := TPhysicalOutputPort (PortList.Items [portNo]);
  instance := port.UserList.Items [userNo];
  instance.MidiOutCallback (uMsg, dw1, dw2);
end;

constructor TPhysicalOutputPort.Create (pID : Integer; user : TMidiOutputPort);
var chan : TChannel;
begin
  inherited Create;
  portID := pID;
  if not Assigned (PortList) then PortList := TList.Create;
  PortNo := PortList.Count;
  PortList.Add (self);
  UserList := TList.Create;
  AddUser (user);

  for chan := Low (TChannel) to High (TChannel) do
  begin
    Move (ControllerDefaults [0], ControllerArray [chan, 0], sizeof (Integer) * High (TController));
    CurrentPatch [chan] := 0;
    CurrentBank [chan] := 127;
  end;

  if midiOutOpen (@Handle, portID, DWORD (@MidiOutCallback), MAKELONG (word (PortNo), word (user.userNo)), CALLBACK_FUNCTION) <> MMSYSERR_NOERROR then
    raise EMidiOutputPort.Create ('Unable to open port');
end;

destructor TPhysicalOutputPort.Destroy;
var
  i : Integer;
  keepList : boolean;
begin
  midiOutReset (Handle);
  Application.ProcessMessages;
  midiOutClose (Handle);
  Application.ProcessMessages;
  keepList := False;

  PortList [PortNo] := Nil;

  for i := 0 to PortList.Count - 1 do
    if PortList.items [i] <> Nil then
    begin
      keepList := True;
      break
    end;

  if not KeepList then
  begin
    PortList.Free;
    PortList:= Nil
  end;
  UserList.Free;
  inherited
end;

constructor TMidiOutputPort.Create (AOwner : TComponent);
begin
   inherited Create (AOwner);
   fSysexHeaders := TList.Create;
   fSysexLatency := 50;
end;

destructor TMidiOutputPort.Destroy;
begin
  Active := False;
  WaitForSysex;
  inherited
end;

procedure TPhysicalOutputPort.RemoveUser (user : TMidiOutputPort);
var
  stillInUse : boolean;
  i : Integer;
begin
  stillInUse := False;
  for i := 0 to UserList.Count - 1 do
    if (UserList.items [i] <> Nil) and (i <> user.userNo) then
    begin
      stillInUse := True;
      break
    end;

  if not stillInUse then
  begin
    if user.userNo <> 0 then UserList.Items [0] := userList.Items [user.userNo];
    Free
  end
  else UserList.Items [user.userNo] := Nil;
end;


procedure TPhysicalOutputPort.AddUser (user : TMidiOutputPort);
var
  slotNo, i : Integer;
begin
  slotNo := -1;
  for i := 0 to UserList.Count - 1 do
    if not Assigned (userList.Items [i]) then
    begin
      slotNo := i;
      break
    end;

  if slotNo <> -1 then
  begin
    UserList.Items [slotNo] := user;
    user.userNo := slotNo
  end
  else
  begin
    user.userNo := UserList.Count;
    UserList.Add (user)
  end
end;

procedure TMidiOutputPort.SetPortId (value : Integer);
var oldActive : boolean;
begin
  if value <> fPortID then
  begin
    oldActive := Active;
    Active := False;
    fPortID := value;
    Active := oldActive
  end
end;

function TMidiOutputPort.GetActive : boolean;
begin
  result := Assigned (fPhysicalPort)
end;

procedure TMidiOutputPort.SetActive (value : boolean);
var
  i : Integer;
begin
  if value <> Active then
  case value of
    True :