FORCER UNE GAMME MUSICALE EN MIDI

Commentaire de Francky23012301 le 10/07/2008 15:10:48

Salut,

Ca pourra aider certains mais quelques remarques:
*En Snippet cela aurait été mieux
*Pourquoi utiliser le type integer : status,channel,data1,data2 sont des bytes
*time ce n'est pas un integer : c'est légèrement plus complexe car il s'agit d'un type de longueur variable. Ton truc marchera pas dans bon nombres de cas

@Jack : Normal que ca ne fasse rien. L'entrée et la sortie Midi ne sont pas sélectionnée. Si tu veux un truc qui fonctionne :

unit MidiCom;

interface

uses
  Windows, SysUtils, Classes, MmSystem, Contnrs;

type

  TOnMidiInReceiveData = procedure(const Status, Data1, Data2: byte) of object;
  TOnMidiInBuffer      = procedure(const AStream: TMemoryStream) of object;

  TMidiCom = class(TComponent)
  private
    MidiIn:      THandle;
    MidiOut:     THandle;
    ResultCom:   MMResult;
    MidiInCount: integer;
    MidiOutCount: integer;
    fDataStream: TMemoryStream;
    fDataHeader: TMidiHdr;
    fExData:     array[0..2048] of char;
    fOnMidiInReceiveData: TOnMidiInReceiveData;
    fOnMidiInBuffer: TOnMidiInBuffer;
    procedure Send_MidiInBuffer;
    procedure Send(const AStream: TMemoryStream); overload;
    procedure Send(const AString: string); overload;
    procedure StrToStream(const AString: string; const AStream: TMemoryStream);
  protected
  public
    function Open_MidiIn(Index: integer): boolean;
    function Open_MidiOut(Index: integer): boolean;
    function Close_MidiIn: boolean;
    function Close_MidiOut: boolean;
    procedure MidiIn_List(AStrings: TStrings);
    procedure MidiOut_List(AStrings: TStrings);
    procedure SendData(Status, Data1, Data2: byte);
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property OnMidiInReceiveData: TOnMidiInReceiveData
      Read fOnMidiInReceiveData Write fOnMidiInReceiveData;
    property OnMidiInBuffer: TOnMidiInBuffer Read fOnMidiInBuffer Write fOnMidiInBuffer;
  end;

var
  AMidiCom: TMidiCom;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('MUSIC_PRO', [TMidiCom]);
end;

procedure MidiInCallBack(AMidiInHandle: PhMidiIn; aMsg: UInt;
  aData, aMidiData, aTimeStamp: integer); stdcall;
begin
  if AMsg = Mim_Data then
    if AMidiCom.MidiIn <> 0 then
      AMidiCom.OnMidiInReceiveData(aMidiData and $000000FF, (aMidiData and $0000FF00) shr
        8, (aMidiData and $00F0000) shr 16);
  if AMsg = Mim_LongData then
    AMidiCom.Send_MidiInBuffer;
end;

constructor TMidiCom.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  MidiInCount := -1;
  MidiOutCount := -1;
  MidiIn      := 0;
  MidiOut     := 0;
  fDataHeader.dwBufferLength := 2048;
  fDataHeader.lpData := fExData;
  fDataStream := TMemoryStream.Create;
  AMidiCom    := Self;
end;

destructor TMidiCom.Destroy;
begin
  fDataStream.Free;
  Close_MidiIn;
  Close_MidiOut;
  inherited;
end;

{>>ENTREE MIDI}

procedure TMidiCom.MidiIn_List(AStrings: TStrings);
var
  Index:  integer;
  InCaps: TMidiInCaps;
begin
  AStrings.Clear;
  for Index := 0 to (MidiInGetNumDevs - 1) do
  begin
    //On récupère les capacités de l'entrée Midi numéro Index
    ResultCom := MidiInGetDevCaps(Index, @InCaps, SizeOf(TMidiInCaps));
    if ResultCom = MmSysErr_NoError then
    begin
      AStrings.Add(InCaps.szPName);
      Inc(MidiInCount);
    end;
  end;
end;

function TMidiCom.Open_MidiIn(Index: integer): boolean;
begin
  Result := False;
  if (MidiInCount > -1) and (Index > -1) and (Index <= MidiInCount) then
  begin
    //Si l'entrée Midi a déjà été définit on sort
    if MidiIn <> 0 then
      Exit;
    //On ouvre l'entrée midi :  MidiInCallBack sera le callback utilisé pour récupérer les données recues
    ResultCom := MidiInOpen(@MidiIn, Index, cardinal(@MidiInCallBack),
      Index, CallBack_Function);
    if ResultCom = MmSysErr_NoError then
    begin
      fDataHeader.dwFlags := 0;
      //On prépare le buffer pour l'entrée Midi
      ResultCom := MidiInPrepareHeader(MidiIn, @fDataHeader, SizeOf(TMidiHdr));
      if ResultCom = MmSysErr_NoError then
      begin
        //On envoit un buffer d'entré dans l'entrée Midi
        ResultCom := MidiInAddBuffer(MidiIn, @fDataHeader, SizeOf(TMidiHdr));
        if ResultCom = MmSysErr_NoError then
        begin
          //On allume l'entrée Midi
          ResultCom := MidiInStart(MidiIn);
          if ResultCom = MmSysErr_NoError then
            Result := True;
        end;
      end;
    end;
  end;
end;

function TMidiCom.Close_MidiIn: boolean;
begin
  Result := False;
  if MidiIn = 0 then
    Exit;
  //On arrète l'entrée midi
  ResultCom := MidiInStop(MidiIn);
  if ResultCom = MmSysErr_NoError then
  begin
    //On détruit l'entrée Midi
    ResultCom := MidiInReset(MidiIn);
    if ResultCom = MmSysErr_NoError then
    begin
      //On nettoye le Buffer
      ResultCom := MidiInUnPrepareHeader(MidiIn, @fDataHeader, SizeOf(TMidiHdr));
      if ResultCom = MmSysErr_NoError then
        Result := True;
    end;
  end;
end;

procedure TMidiCom.Send_MidiInBuffer;
begin
  if fDataHeader.dwBytesRecorded = 0 then
    Exit;
  fDataStream.Write(fExData, fDataHeader.dwBytesRecorded);
  if fDataHeader.dwFlags and MHdr_Done = MHdr_Done then
  begin
    fDataStream.Position := 0;
    fOnMidiInBuffer(fDataStream);
    fDataStream.Clear;
  end;
  fDataHeader.dwBytesRecorded := 0;
  //On prépare le buffer pour l'entrée Midi
  ResultCom := MidiInPrepareHeader(MidiIn, @fDataHeader, SizeOf(TMidiHdr));
  if ResultCom = MmSysErr_NoError then
  begin
    //On envoit un buffer d'entré dans l'entrée Midi
    ResultCom := MidiInAddBuffer(MidiIn, @fDataHeader, SizeOf(TMidiHdr));
  end;
end;


{>>SORTIE MIDI}

procedure TMidiCom.MidiOut_List(AStrings: TStrings);
var
  Index:   integer;
  OutCaps: TMidiOutCaps;
begin
  AStrings.Clear;
  for Index := 0 to (MidiOutGetNumDevs - 1) do
  begin
    //On récupère les capacités de la sortie Midi numéro Index
    ResultCom := MidiOutGetDevCaps(Index, @OutCaps, SizeOf(TMidiOutCaps));
    if ResultCom = MmSysErr_NoError then
    begin
      AStrings.Add(OutCaps.szPName);
      Inc(MidiOutCount);
    end;
  end;
end;

function TMidiCom.Close_MidiOut: boolean;
begin
  Result    := False;
  ResultCom := MidiOutClose(MidiOut);
  if ResultCom = MmSysErr_NoError then
    Result := True;
end;

function TMidiCom.Open_MidiOut(Index: integer): boolean;
begin
  Result := False;
  if (MidiOutCount > -1) and (Index > -1) and (Index <= MidiOutCount) then
  begin
    if MidiOut <> 0 then
      Exit;
    //Ouverture de la sortie Midi
    ResultCom := MidiOutOpen(@MidiOut, Index, 0, 0, CallBack_Null);
    if ResultCom = MmSysErr_NoError then
      Result := True;
  end;
end;

procedure TMidiCom.SendData(Status, Data1, Data2: byte);
var
  AMsg: cardinal;
begin
  if MidiOut = 0 then
    Exit;
  AMsg      := Status + (Data1 * $100) + (Data2 * $10000);
  //On envoit le message à la sortie Midi
  ResultCom := MidiOutShortMsg(MidiOut, AMsg);
end;

procedure TMidiCom.Send(const AString: string);
var
  AStream: TMemoryStream;
begin
  AStream := TMemoryStream.Create;
  try
    StrToStream(AString, AStream);
    Send(AStream);
  finally
    AStream.Free;
  end;
end;

procedure TMidiCom.Send(const AStream: TMemoryStream);
var
  ADataHeader: TMidiHdr;
begin
  AStream.Position := 0;
  ADataHeader.dwBufferLength := AStream.Size;
  ADataHeader.lpData := AStream.Memory;
  ADataHeader.dwFlags := 0;
  //Préparation de la zone tambon pour la sortie Midi
  ResultCom := MidiOutPrepareHeader(MidiOut, @ADataHeader, SizeOf(TMidiHdr));
  if ResultCom = MmSysErr_NoError then
  begin
    //On envoit le message à la sortie Midi
    ResultCom := MidiOutLongMsg(MidiOut, @ADataHeader, SizeOf(TMidiHdr));
    if ResultCom = MmSysErr_NoError then
      //On nettoye le Buffer
      ResultCom := MidiOutUnPrepareHeader(MidiOut, @ADataHeader, SizeOf(TMidiHdr));
  end;
end;

procedure TMidiCom.StrToStream(const AString: string; const AStream: TMemoryStream);
const
  HexChar = '123456789ABCDEF';
var
  Index: integer;
  Str:   string;
begin
  Str := StringReplace(AnsiUpperCase(AString), '  ', '', [rfReplaceAll]);
  AStream.Position := 0;
  for Index := 1 to (Length(Str) div 2 - 1) do
    PChar(AStream.Memory)[Index - 1] :=
      char(AnsiPos(Str[Index * 2 - 1], HexChar) shl 4 + AnsiPos(Str[Index * 2], HexChar));
end;

L'idée est cependant louable ;).