Forcer une gamme musicale en midi

Soyez le premier à donner votre avis sur cette source.

Snippet vu 6 021 fois - Téléchargée 309 fois

Contenu du snippet

Ce code utilise un algorythme simple qui permet d'appliquer une transposition midi aux messages midi de types note on/note off.Il est utilisable dans le contexte d'un instruemnt vsti ou d'une application midi.

Source / Exemple :


type
TScale  = array [0..11] of integer;

====================================================================

    Scale: TScale;

// les gammes courantes converties en table de transposition

                    //     Db     Eb        Gb     Ab     Bb
  const            //   C  C#  D  D#  E  F  F#  G  G#  A  A#  B
    Maj    : TScale = ( 0, -1, 0, -1, 0, 0, -1, 0, -1, 0, -1, 0);
    MinNat : TScale = ( 0, -1, 0,  0,-1, 0, -1, 0, -1, 0,  0,-1);
    MinMelo: TScale = ( 0, -1, 0,  0,-1, 0, -1, 0,  0,-1, -1, 0);
    MinHarm: TScale = ( 0, -1, 0,  0,-1, 0, -1, 0,  0,-1,  0,-1);
    _7ThDom: Tscale = ( 0, -1, 0, -1, 0, 0, -1, 0, -1, 0,  0,-1);
    DoriMin: Tscale = ( 0, -1, 0,  0,-1, 0, -1, 0, -1, 0,  0,-1);
    Locrian: Tscale = ( 0,  0,-1,  0,-1, 0,  0,-1,  0,-1,  0,-1);
    Dim    : TScale = ( 0, -1, 0,  0,-1, 0,  0,-1,  0, 0, -1, 0);
    PentMaj: Tscale = ( 0, -1, 0, -1, 0,-1, -2, 0, -1, 0, -1,-2);
    PentMin: Tscale = ( 0, -1,-2,  0,-1, 0, -1, 0, -1,-2,  0,-1);
    Blues  : Tscale = ( 0, -1,-2,  0,-1, 0,  0, 0, -1,-2,  0,-1);
    DemiTT : Tscale = ( 0, -1, 0, -1, 0,-1,  0,-1,  0,-1,  0,-1);
    TT     : Tscale = ( 0, -1, 0, -1, 0,-1,  0,-1,  0,-1,  0,-1);
    BBmaj  : Tscale = ( 0, -1, 0, -1, 0, 0, -1, 0,  0, 0, -1, 0);
    BBDom  : Tscale = ( 0, -1, 0, -1, 0, 0, -1, 0, -1, 0,  0, 0);
    BBmin  : TScale = ( 0, -1, 0,  0, 0, 0, -1, 0, -1, 0,  0,-1);
    Lydian : TScale = ( 0, -1, 0, -1, 0,-1,  0, 0, -1, 0, -1, 0);
    LydDom : Tscale = ( 0, -1, 0, -1, 0,-1,  0, 0, -1, 0,  0,-1);
    Augm   : Tscale = ( 0, -1,-2,  0, 0,-1, -2, 0,  0,-1, -2, 0);
    Phryg  : TScale = ( 0,  0,-1,  0,-1, 0, -1, 0,  0,-1,  0,-1);
    TFullD : Tscale = ( 0,  0,-1,  0, 0,-1,  0,-1,  0,-1,  0,-1);

========================================================================

procedure processMIDI(time,status,channel,data1,data2:integer);
begin
  if (Status=$90) or (Status=$80) then
    begin                // scale = pointer vers une des TScale déclarée en constante
      n:= data1 mod 12; // détéction de la note courante quelque soit l'octave
      n:= scale[n]+key; // key = dominante de la gamme , on ajoute la valeur de transposition
      data1:= data1+n;  // à la valeur initiale
    end;
  case status of
    $80: MIDI_NoteOff(channel,data1,data2,0);    // sortie midi spécifique au programme :
    $90: MIDI_NoteOn(channel,data1,data2,0);     // thru (in = out) sauf s'il faut transposer.
    $A0: MIDI_PolyAftertouch(channel,data1,data2,0);
    $B0: MIDI_CC(channel,data1,data2,0);
    $C0: MIDI_ProgramChange(channel,data1,0);
    $D0: MIDI_ChannelAftertouch(channel,data1,0);
    $E0: MIDI_PitchBend2(channel,data1,data2,0);
  end;

A voir également

Ajouter un commentaire Commentaires
Messages postés
1
Date d'inscription
jeudi 12 août 2004
Statut
Membre
Dernière intervention
12 avril 2009

Le code présenté est basé sur le template VST de Tobybear. Hors dece cadre, en effet ça ne veut pas dire grand-chose.
Messages postés
400
Date d'inscription
samedi 6 août 2005
Statut
Membre
Dernière intervention
11 février 2016
1
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 ;).
Messages postés
128
Date d'inscription
mercredi 8 janvier 2003
Statut
Membre
Dernière intervention
14 juillet 2008

J'ai compris a quoi consitste cette procedure , elle est trés utile mais elle marche pas pour moi. mais ça mèrite

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.