Envoi de Sysex MIDI ????
Dordi
Messages postés
1
Date d'inscription
mercredi 30 mars 2005
Statut
Membre
Dernière intervention
23 avril 2005
-
23 avril 2005 à 14:41
petiflamand Messages postés 675 Date d'inscription samedi 31 mai 2003 Statut Membre Dernière intervention 26 mai 2013 - 15 juin 2011 à 18:38
petiflamand Messages postés 675 Date d'inscription samedi 31 mai 2003 Statut Membre Dernière intervention 26 mai 2013 - 15 juin 2011 à 18:38
6 réponses
NumberAtlas
Messages postés
2
Date d'inscription
dimanche 10 mai 2009
Statut
Membre
Dernière intervention
13 mai 2009
2
13 mai 2009 à 17:14
13 mai 2009 à 17:14
ENVOI DE MESSAGES MIDI SysEx<?xml:namespace prefix = o ns = "urn:schemas-microsoft-com:office:office" /??>
Le programme qui suit fonctionne dans Excel VBA. Il ne reste qu'à créer un formulaire avec les boutons et menus déroulants nécessaires : un menu déroulant de choix de périphérique, un bouton de sélection du fichier SysEx et un bouton d'envoi des données.
Tout le code est là.
Le programme nécessite de savoir via quel périphérique MIDI il faut envoyer les données. Le programme qui suit inscrit le nom des périphérique dans les cellules "AB4" et plus. Il suffit d'ajouter un menu déroulant à un formulaire et de l'associer aux cellules correspondantes.
Programmes de sélection du periphique MIDI
' == =================================================
Const MAXPNAMELEN = 32
Private Type MIDIOUTCAPS
wMid As Integer
wPid As Integer
vDriverVersion As Long
szPname As String * MAXPNAMELEN
wTechnology As Integer
wVoices As Integer
wNotes As Integer
wChannelMask As Integer
dwSupport As Long
End Type
Private Declare Function midiOutGetDevCaps Lib "winmm.dll" Alias "midiOutGetDevCapsA" (ByVal uDeviceID As Long, lpCaps As MIDIOUTCAPS, ByVal uSize As Long) As Long
Private Declare Function midiOutGetNumDevs Lib "winmm" () As Integer
'===================================================
Public Sub Midi_Device()
Dim MidiCaps As MIDIOUTCAPS, Cnt As Long
Feuil1.Range("AA2") = "Available midi devices:" + str$(midiOutGetNumDevs)
For Cnt = 0 To midiOutGetNumDevs - 1
'Get the device name and capabilities
midiOutGetDevCaps Cnt, MidiCaps, Len(MidiCaps)
Feuil1.Range("AA" & Cnt + 4) = "Device name" + str$(Cnt + 1) + ": "
Feuil1.Range("AB" & Cnt + 4) = MidiCaps.szPname
Next Cnt
End Sub
'===================================================
Le programme doit permettre l'ouverture d'une fenêtre de sélection de fichiers. Une fois le fichier de format SysEx sélectionné, les données sont traitées sous forme de messages SysEx (F0...F7).
Programmes de sélection d'un fichier et de préparation des messages SysEx...
' ===================================================
Public SysEx(1000) As String
Public Mess As Integer
Dim Long_File As Long
Sub Ouvrir_Fichier()
Dim Filter As String
Dim SelectedFile As String, Repertoire As String, Fichier As String
Dim Pos As Integer
Filter = "MIDI System Exclusive files (*.*),*.*"
Caption = "Ouvrir " & TheUser
SelectedFile = Application.GetOpenFilename(Filter, , Caption) 'Ouvrir la fenêtre de sélection d'un fichier
If Len(SelectedFile) > 4 Then
Pos = InStrRev(SelectedFile, "")
Repertoire = Mid(SelectedFile, 1, Pos)
Fichier = Mid(SelectedFile, Pos + 1, 100)
z = Lire(SelectedFile)
End If
End Sub
Function Lire(File As String)
Dim x As Long, a As Long
Dim Text As String, lText As String
Dim B(1000000) As Byte
Dim ff As Integer
For a = 0 To 999
SysEx(a) = ""
Next a
Mess = 0
ff = FreeFile
Open File For Binary As #ff 'Ouvrir le fichier en lecture binaire
Long_File = LOF(ff) - 1
Get ff, , B
Close #ff 'Fermer le fichier
Mess = -1
a = 0
While a < Long_File + 1 'Préparation des données à envoyer
If B(a) 240 Then Mess Mess + 1: lText = "": SysEx(Mess) = ""
Text = Hex(B(a))
lText = lText & Chr("&H" & Text)
If B(a) = 247 Then
SysEx(Mess) = Mid(lText, 1, 1000000)
End If
a = a + 1
Wend
End Function
'===================================================
Programmes d'envoi des messages SysEx...
Option Explicit
'===================================================
Public Declare Function MySetFocus Lib "user32" Alias "SetFocus" (ByVal hWnd As Long) As Long
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" (ByVal lpstrCommand As String, ByVal lpstrReturnString As String, ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long
Public hMidi As Long ' midi output handle
Public rc As Long ' return code
Public midiMsg As Long ' midi output short message buffer
Public Channel As Integer ' midi output channel
Public volume As Integer ' midi velocity
Public LastNote As Integer ' Last note to stop in our piano
Public baseNote As Integer ' the first note on our "piano"
Public sendmsg As String ' SysEx msg
Public YMH_MSG As String ' Yamaha SysEx ID
'==================================================
Public Declare Function midiOutOpen Lib "winmm.dll" (lphMidiOut As Long, ByVal uDeviceID As Long, ByVal dwCallback As Long, ByVal dwInstance As Long, ByVal dwFlags As Long) As Long
Public Declare Function midiOutClose Lib "winmm.dll" (ByVal hMidiOUT As Long) As Long
Public Declare Function midiOutShortMsg Lib "winmm.dll" (ByVal hMidiOUT As Long, ByVal dwMsg As Long) As Long
Public Declare Function midiOutPrepareHeader Lib "winmm.dll" (ByVal hMidiOUT As Long, lpMidiOutHdr As MIDIHDR, ByVal uSize As Long) As Long
Public Declare Function midiOutUnprepareHeader Lib "winmm.dll" (ByVal hMidiOUT As Long, lpMidiOutHdr As MIDIHDR, ByVal uSize As Long) As Long
Public Declare Function midiOutLongMsg Lib "winmm.dll" (ByVal hMidiOUT As Long, lpMidiOutHdr As MIDIHDR, ByVal uSize As Long) As Long
Public Type MIDIHDR
lpData As String 'Address of MIDI data
dwBufferLength As Long 'Size of the buffer
dwBytesRecorded As Long 'Actual amount of data in the buffer. This value should be less than or equalto the value given in the dwBufferLength member
dwUser As Long 'Custom user data
dwFlags As Long 'Flags giving information about the buffer
lpNext As Long 'Reserved - do not use
Reserved As Long 'Reserved - do not use
End Type
Public Declare Function midiOutGetErrorText Lib "winmm.dll" Alias "midiOutGetErrorTextA" (ByVal err As Long, ByVal lpText As String, ByVal uSize As Long) As Long
' Error values for functions used in this sample. See the function for more information
Public Const MMSYSERR_BASE = 0
Public Const MMSYSERR_BADDEVICEID = (MMSYSERR_BASE + 2) ' device ID out of range
Public Const MMSYSERR_INVALPARAM = (MMSYSERR_BASE + 11) ' invalid parameter passed
Public Const MMSYSERR_NODRIVER = (MMSYSERR_BASE + 6) ' no device driver present
Public Const MMSYSERR_NOMEM = (MMSYSERR_BASE + 7) ' memory allocation error
Public Const MMSYSERR_INVALHANDLE = (MMSYSERR_BASE + 5) ' device handle is invalid
Public Const MIDIERR_BASE = 64
Public Const MIDIERR_STILLPLAYING = (MIDIERR_BASE + 1) ' still something playing
Public Const MIDIERR_NOTREADY = (MIDIERR_BASE + 3) ' hardware is still busy
Public Const MIDIERR_BADOPENMODE = (MIDIERR_BASE + 6) ' operation unsupported w/ open mode
'==================================================
' Send System Exclusive Message
Public Function SetSysEx(sSysEx As String)
Dim mhdr As MIDIHDR
Dim LenSysEx As Long
LenSysEx = Len(sSysEx)
With mhdr
.lpData = sSysEx
.dwBufferLength = LenSysEx
.dwBytesRecorded = LenSysEx
.dwUser = 0
.dwFlags = 0
End With
rc = midiOutPrepareHeader(hMidi, mhdr, Len(mhdr)) ' MIDIOutPrepareHeader
If rc <> 0 Then
getMIDIoutErrText "preparing header", rc
Exit Function
End If
rc = midiOutLongMsg(hMidi, mhdr, Len(mhdr)) ' MIDIOut --> envoi du message SysEx
Sleep 50
If rc <> 0 Then
getMIDIoutErrText "sending long message", rc
Exit Function
End If
mhdr.dwFlags = 0
rc = midiOutUnprepareHeader(hMidi, mhdr, Len(mhdr)) ' MIDIOutUNprepareHeader --> message terminé
If rc <> 0 Then
getMIDIoutErrText "unpreparing header", rc
Exit Function
End If
End Function
' Get MIDI-out error text
Public Function getMIDIoutErrText(ByVal sEvent As String, ByVal nRc As Integer)
Dim errText As String * 132
midiOutGetErrorText rc, errText, 128
MsgBox "Error in " & sEvent & Chr(13) & Chr(10) & errText
End Function
Sub Envoyer_DATA()
Dim a As Integer, r As Long, Device As Long
'La valeur de Device est un INTEGER
Device = Feuil1.Range("AC2") ' Choix du périphérique MIDI
r = midiOutOpen(hMidi, Device, 0, 0, 0) ' Ouvrir la connexion MIDI
For a = 0 To Mess ' Envoi de tous les blocs de messages (F0...F7)
r = SetSysEx(SysEx(a))
Pause (0.5) ' Pause de 0.5 seconde entre les messages
Next a
r = midiOutClose(hMidi) ' Fermer la connexion MIDI
Beep
End Sub
Public Function Pause(sec As Double)
a = Timer + sec
While Timer < a
Wend
End Function
'===================================================
'C.Q.F.D [mailto:NumberAtlas@hotmail.com NumberAtlas@hotmail.com]
Le programme qui suit fonctionne dans Excel VBA. Il ne reste qu'à créer un formulaire avec les boutons et menus déroulants nécessaires : un menu déroulant de choix de périphérique, un bouton de sélection du fichier SysEx et un bouton d'envoi des données.
Tout le code est là.
Le programme nécessite de savoir via quel périphérique MIDI il faut envoyer les données. Le programme qui suit inscrit le nom des périphérique dans les cellules "AB4" et plus. Il suffit d'ajouter un menu déroulant à un formulaire et de l'associer aux cellules correspondantes.
Programmes de sélection du periphique MIDI
' == =================================================
Const MAXPNAMELEN = 32
Private Type MIDIOUTCAPS
wMid As Integer
wPid As Integer
vDriverVersion As Long
szPname As String * MAXPNAMELEN
wTechnology As Integer
wVoices As Integer
wNotes As Integer
wChannelMask As Integer
dwSupport As Long
End Type
Private Declare Function midiOutGetDevCaps Lib "winmm.dll" Alias "midiOutGetDevCapsA" (ByVal uDeviceID As Long, lpCaps As MIDIOUTCAPS, ByVal uSize As Long) As Long
Private Declare Function midiOutGetNumDevs Lib "winmm" () As Integer
'===================================================
Public Sub Midi_Device()
Dim MidiCaps As MIDIOUTCAPS, Cnt As Long
Feuil1.Range("AA2") = "Available midi devices:" + str$(midiOutGetNumDevs)
For Cnt = 0 To midiOutGetNumDevs - 1
'Get the device name and capabilities
midiOutGetDevCaps Cnt, MidiCaps, Len(MidiCaps)
Feuil1.Range("AA" & Cnt + 4) = "Device name" + str$(Cnt + 1) + ": "
Feuil1.Range("AB" & Cnt + 4) = MidiCaps.szPname
Next Cnt
End Sub
'===================================================
Le programme doit permettre l'ouverture d'une fenêtre de sélection de fichiers. Une fois le fichier de format SysEx sélectionné, les données sont traitées sous forme de messages SysEx (F0...F7).
Programmes de sélection d'un fichier et de préparation des messages SysEx...
' ===================================================
Public SysEx(1000) As String
Public Mess As Integer
Dim Long_File As Long
Sub Ouvrir_Fichier()
Dim Filter As String
Dim SelectedFile As String, Repertoire As String, Fichier As String
Dim Pos As Integer
Filter = "MIDI System Exclusive files (*.*),*.*"
Caption = "Ouvrir " & TheUser
SelectedFile = Application.GetOpenFilename(Filter, , Caption) 'Ouvrir la fenêtre de sélection d'un fichier
If Len(SelectedFile) > 4 Then
Pos = InStrRev(SelectedFile, "")
Repertoire = Mid(SelectedFile, 1, Pos)
Fichier = Mid(SelectedFile, Pos + 1, 100)
z = Lire(SelectedFile)
End If
End Sub
Function Lire(File As String)
Dim x As Long, a As Long
Dim Text As String, lText As String
Dim B(1000000) As Byte
Dim ff As Integer
For a = 0 To 999
SysEx(a) = ""
Next a
Mess = 0
ff = FreeFile
Open File For Binary As #ff 'Ouvrir le fichier en lecture binaire
Long_File = LOF(ff) - 1
Get ff, , B
Close #ff 'Fermer le fichier
Mess = -1
a = 0
While a < Long_File + 1 'Préparation des données à envoyer
If B(a) 240 Then Mess Mess + 1: lText = "": SysEx(Mess) = ""
Text = Hex(B(a))
lText = lText & Chr("&H" & Text)
If B(a) = 247 Then
SysEx(Mess) = Mid(lText, 1, 1000000)
End If
a = a + 1
Wend
End Function
'===================================================
Programmes d'envoi des messages SysEx...
Option Explicit
'===================================================
Public Declare Function MySetFocus Lib "user32" Alias "SetFocus" (ByVal hWnd As Long) As Long
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" (ByVal lpstrCommand As String, ByVal lpstrReturnString As String, ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long
Public hMidi As Long ' midi output handle
Public rc As Long ' return code
Public midiMsg As Long ' midi output short message buffer
Public Channel As Integer ' midi output channel
Public volume As Integer ' midi velocity
Public LastNote As Integer ' Last note to stop in our piano
Public baseNote As Integer ' the first note on our "piano"
Public sendmsg As String ' SysEx msg
Public YMH_MSG As String ' Yamaha SysEx ID
'==================================================
Public Declare Function midiOutOpen Lib "winmm.dll" (lphMidiOut As Long, ByVal uDeviceID As Long, ByVal dwCallback As Long, ByVal dwInstance As Long, ByVal dwFlags As Long) As Long
Public Declare Function midiOutClose Lib "winmm.dll" (ByVal hMidiOUT As Long) As Long
Public Declare Function midiOutShortMsg Lib "winmm.dll" (ByVal hMidiOUT As Long, ByVal dwMsg As Long) As Long
Public Declare Function midiOutPrepareHeader Lib "winmm.dll" (ByVal hMidiOUT As Long, lpMidiOutHdr As MIDIHDR, ByVal uSize As Long) As Long
Public Declare Function midiOutUnprepareHeader Lib "winmm.dll" (ByVal hMidiOUT As Long, lpMidiOutHdr As MIDIHDR, ByVal uSize As Long) As Long
Public Declare Function midiOutLongMsg Lib "winmm.dll" (ByVal hMidiOUT As Long, lpMidiOutHdr As MIDIHDR, ByVal uSize As Long) As Long
Public Type MIDIHDR
lpData As String 'Address of MIDI data
dwBufferLength As Long 'Size of the buffer
dwBytesRecorded As Long 'Actual amount of data in the buffer. This value should be less than or equalto the value given in the dwBufferLength member
dwUser As Long 'Custom user data
dwFlags As Long 'Flags giving information about the buffer
lpNext As Long 'Reserved - do not use
Reserved As Long 'Reserved - do not use
End Type
Public Declare Function midiOutGetErrorText Lib "winmm.dll" Alias "midiOutGetErrorTextA" (ByVal err As Long, ByVal lpText As String, ByVal uSize As Long) As Long
' Error values for functions used in this sample. See the function for more information
Public Const MMSYSERR_BASE = 0
Public Const MMSYSERR_BADDEVICEID = (MMSYSERR_BASE + 2) ' device ID out of range
Public Const MMSYSERR_INVALPARAM = (MMSYSERR_BASE + 11) ' invalid parameter passed
Public Const MMSYSERR_NODRIVER = (MMSYSERR_BASE + 6) ' no device driver present
Public Const MMSYSERR_NOMEM = (MMSYSERR_BASE + 7) ' memory allocation error
Public Const MMSYSERR_INVALHANDLE = (MMSYSERR_BASE + 5) ' device handle is invalid
Public Const MIDIERR_BASE = 64
Public Const MIDIERR_STILLPLAYING = (MIDIERR_BASE + 1) ' still something playing
Public Const MIDIERR_NOTREADY = (MIDIERR_BASE + 3) ' hardware is still busy
Public Const MIDIERR_BADOPENMODE = (MIDIERR_BASE + 6) ' operation unsupported w/ open mode
'==================================================
' Send System Exclusive Message
Public Function SetSysEx(sSysEx As String)
Dim mhdr As MIDIHDR
Dim LenSysEx As Long
LenSysEx = Len(sSysEx)
With mhdr
.lpData = sSysEx
.dwBufferLength = LenSysEx
.dwBytesRecorded = LenSysEx
.dwUser = 0
.dwFlags = 0
End With
rc = midiOutPrepareHeader(hMidi, mhdr, Len(mhdr)) ' MIDIOutPrepareHeader
If rc <> 0 Then
getMIDIoutErrText "preparing header", rc
Exit Function
End If
rc = midiOutLongMsg(hMidi, mhdr, Len(mhdr)) ' MIDIOut --> envoi du message SysEx
Sleep 50
If rc <> 0 Then
getMIDIoutErrText "sending long message", rc
Exit Function
End If
mhdr.dwFlags = 0
rc = midiOutUnprepareHeader(hMidi, mhdr, Len(mhdr)) ' MIDIOutUNprepareHeader --> message terminé
If rc <> 0 Then
getMIDIoutErrText "unpreparing header", rc
Exit Function
End If
End Function
' Get MIDI-out error text
Public Function getMIDIoutErrText(ByVal sEvent As String, ByVal nRc As Integer)
Dim errText As String * 132
midiOutGetErrorText rc, errText, 128
MsgBox "Error in " & sEvent & Chr(13) & Chr(10) & errText
End Function
Sub Envoyer_DATA()
Dim a As Integer, r As Long, Device As Long
'La valeur de Device est un INTEGER
Device = Feuil1.Range("AC2") ' Choix du périphérique MIDI
r = midiOutOpen(hMidi, Device, 0, 0, 0) ' Ouvrir la connexion MIDI
For a = 0 To Mess ' Envoi de tous les blocs de messages (F0...F7)
r = SetSysEx(SysEx(a))
Pause (0.5) ' Pause de 0.5 seconde entre les messages
Next a
r = midiOutClose(hMidi) ' Fermer la connexion MIDI
Beep
End Sub
Public Function Pause(sec As Double)
a = Timer + sec
While Timer < a
Wend
End Function
'===================================================
'C.Q.F.D [mailto:NumberAtlas@hotmail.com NumberAtlas@hotmail.com]
NoKurzTif
Messages postés
2
Date d'inscription
samedi 22 janvier 2005
Statut
Membre
Dernière intervention
13 novembre 2006
15 août 2005 à 10:06
15 août 2005 à 10:06
S'lut. Moi aussi j'avais cherché longtemps... Si c'est relativement simple pour les messages courts, cela devient lourd pour les SYSEX longs. Jai pas de solution à ce jour, alors si tu trouves fais moi signe !
Biene sûr, je ferais de même
Biene sûr, je ferais de même
cs_tonton2
Messages postés
7
Date d'inscription
samedi 18 octobre 2003
Statut
Membre
Dernière intervention
31 mars 2010
16 mai 2009 à 01:25
16 mai 2009 à 01:25
Bonsoir NumberAtlas
Eh bien cela en fait des lignes ...........
Aurais-tu le temps de me donner la manip inverse c'est a dire la réception
des sysex ? sur un Midi In
Merci pour ton aide éventuel
David
Eh bien cela en fait des lignes ...........
Aurais-tu le temps de me donner la manip inverse c'est a dire la réception
des sysex ? sur un Midi In
Merci pour ton aide éventuel
David
cs_tonton2
Messages postés
7
Date d'inscription
samedi 18 octobre 2003
Statut
Membre
Dernière intervention
31 mars 2010
2 juil. 2009 à 17:21
2 juil. 2009 à 17:21
Ok c'est bon je le fait en Delphi.................
David
David
Vous n’avez pas trouvé la réponse que vous recherchez ?
Posez votre question
zbabug
Messages postés
9
Date d'inscription
lundi 24 février 2003
Statut
Membre
Dernière intervention
2 août 2010
2 août 2010 à 11:13
2 août 2010 à 11:13
Voici une moyen simple d'envoyer un SysEx
MIDI-SYSEX-ENVOIE-MESSAGE-LONG-CONTROLEUR-MIDI
MIDI-SYSEX-ENVOIE-MESSAGE-LONG-CONTROLEUR-MIDI
petiflamand
Messages postés
675
Date d'inscription
samedi 31 mai 2003
Statut
Membre
Dernière intervention
26 mai 2013
1
15 juin 2011 à 18:38
15 juin 2011 à 18:38
Bonjour ,
je cherche la reception de sysex mais en vb6
si quelqu'un peu m'aider merci d'avance
Robert
je cherche la reception de sysex mais en vb6
si quelqu'un peu m'aider merci d'avance
Robert