|
Buonasera a tutti,
cerco aiuto al fine di terminare l'aquisifione dei codici midi provenienti da un mixer audio digitale in formarmato SysEx.
Ho realizzato un modulo che però non mi funziona come callback ma che devo ogni volta richiamare per caricare nel buffer il codice.
Option Explicit
Dim mInDev As Integer
Dim DispBuffStr(0 To 254) As midiBuffer
'Sleep (3000) '// Will pause for 3 seconds
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
'Function declarations for midi in
Declare Function midiInGetNumDevs Lib "winmm.dll" () As Long
Declare Function midiInGetDevCaps Lib "winmm.dll" Alias "midiInGetDevCapsA" (ByVal uDeviceID As Long, lpCaps As MIDIINCAPS, ByVal uSize As Long) As Long
Declare Function midiInOpen Lib "winmm.dll" (lphMidiIn As Long, ByVal uDeviceID As Long, ByVal dwCallback As Any, ByVal dwInstance As Long, ByVal dwFlags As Long) As Long
Declare Function midiInPrepareHeader Lib "winmm.dll" (ByVal hMidiIn As Long, lpMidiInHdr As MIDIHDR, ByVal uSize As Long) As Long
Declare Function midiInAddBuffer Lib "winmm.dll" (ByVal hMidiIn As Long, lpMidiInHdr As MIDIHDR, ByVal uSize As Long) As Long
Declare Function midiInStart Lib "winmm.dll" (ByVal hMidiIn As Long) As Long
Declare Function midiInStop Lib "winmm.dll" (ByVal hMidiIn As Long) As Long
Declare Function midiInReset Lib "winmm.dll" (ByVal hMidiIn As Long) As Long
Declare Function midiInUnprepareHeader Lib "winmm.dll" (ByVal hMidiIn As Long, lpMidiInHdr As MIDIHDR, ByVal uSize As Long) As Long
Declare Function midiInClose Lib "winmm.dll" (ByVal hMidiIn As Long) As Long
Declare Function midiInGetErrorText Lib "winmm.dll" Alias "midiInGetErrorTextA" (ByVal err As Long, ByVal lpText As String, ByVal uSize As Long) As Long
'Declare Function midiInGetID Lib "winmm.dll" (ByVal hMidiIn As Long, lpuDeviceID As Long) As Long
'Declare Function midiInMessage Lib "winmm.dll" (ByVal hMidiIn As Long, ByVal msg As Long, ByVal dw1 As Long, ByVal dw2 As Long) As Long
Public Const MAXPNAMELEN = 32 ' max product name length (including NULL)
Public Const MIDI_MAPPER = -1
Public Const IN_BUFFER_LEN = 255 'midiInString Buffer
'Use with midiInGetDevCaps
Type MIDIINCAPS
wMid As Integer
wPid As Integer
vDriverVersion As Long
szPname As String * MAXPNAMELEN
End Type
Type MIDIHDR ' MIDI data block header
lpData As Long '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 equal to the value given in the dwBufferLength member
dwUser As Long 'Custom user data
dwFlags As Long 'Flags giving information about the buffer
'MHDR_DONE
'Set by the device driver to indicate that it is finished with the buffer and is returning it to the application
'MHDR_INQUEUE
'Set by Windows to indicate that the buffer is queued for playback
'MHDR_ISSTRM
'Set to indicate that the buffer is a stream buffer.
'MHDR_PREPARED
'Set by Windows to indicate that the buffer has been prepared by using the midiInPrepareHeader or midiOutPrepareHeader function
lpNext As Long 'Reserved - do not use
reserved As Long 'Reserved - do not use
dwOffset As Long 'Offset into the buffer when a callback is performed
dwReserved(4) As Long 'Reserved - do not use
End Type
Type MIDIEVENT
dwDeltaTime As Long ' Ticks since last event
dwStreamID As Long ' Reserved; must be zero
dwEvent As Long ' Event type and parameters
dwParms(1) As Long ' Parameters if this is a long event
End Type
Type MIDIPROPTEMPO
cbStruct As Long
dwTempo As Long
End Type
Type MIDIPROPTIMEDIV
cbStruct As Long
dwTimeDiv As Long
End Type
Type MIDISTRMBUFFVER
dwVersion As Long 'Stream buffer format version
dwMid As Long 'Manufacturer ID as defined in MMREG.H
dwOEMVersion As Long 'Manufacturer version for custom ext
End Type
Type MMTIME
wType As Long
u As Long
End Type
'user added
Type midiBuffer
syxType As String * 4
midiData As String * 255
End Type
Public Const CALLBACK_TYPEMASK = &H70000 ' callback type mask
Public Const CALLBACK_NULL = &H0 ' no callback
Public Const CALLBACK_WINDOW = &H10000 ' dwCallback is a HWND
Public Const CALLBACK_TASK = &H20000 ' dwCallback is a HTASK
Public Const CALLBACK_FUNCTION = &H30000 ' dwCallback is a FARPROC
Dim midiInString(IN_BUFFER_LEN) As Byte ' Make sure this is big enough!
Dim lpMidiHeader As Long
Dim midiInHdr As MIDIHDR
Dim inMidiOpen As Boolean
Dim hInMidi As Long 'Holds address of MIDIHDR
Dim tmp As Long
Global var_MidiInRxStatus As Boolean
Public Function Memorize_Event(ByVal MidiInHandle As Long, ByVal wMsg As Long, ByVal Instance As Long, ByVal dw1 As Long, ByVal dw2 As Long) As Long
'configured as shown in MidiInProc notes
'NOTE: Do not put code in this function If using
'callback for sysex. See MidiInProc remarks.
End Function
Public Function fnc_MidiInOpen()
Dim ct As Integer
Dim Length As Integer
Length = IN_BUFFER_LEN
For ct = 0 To Length - 1
midiInString(ct) = 0 'c++ end of string char
Next ct
With midiInHdr
.lpData = VarPtr(midiInString(0)) ' Undocumented feature!
.dwBufferLength = Length
.dwBytesRecorded = Length - 1 ' Was Length - only used for MIDI in
.dwUser = 0
.dwFlags = 0
End With
tmp = midiInOpen(hInMidi, mInDev, AddressOf Memorize_Event, 0, CALLBACK_FUNCTION)
tmp = midiInPrepareHeader(hInMidi, midiInHdr, LenB(midiInHdr))
End Function
Public Function fnc_MidiInRxStart()
var_MidiInRxStatus = True
Call fnc_MidiInRxMsg
End Function
Public Function fnc_MidiInRxStop()
var_MidiInRxStatus = False
End Function
Private Function fnc_MidiInRxMsg()
'On Error Resume Next
Do While var_MidiInRxStatus = True
'Starts midi input on dev
tmp = midiInStart(hInMidi)
'send an input buffer to midi input dev
tmp = midiInAddBuffer(hInMidi, midiInHdr, LenB(midiInHdr))
'allow time to receive data
Sleep (5) 'enter milliseconds
If midiInHdr.dwBytesRecorded > 0 Then Call fnc_MidiInRxView
' tmp = midiInReset(hInMidi)
' tmp = midiInStop(hInMidi)
Loop
End Function
Function fnc_MidiInClose()
tmp = midiInClose(hInMidi)
End Function
Function fnc_MidiInRxView()
Dim ct As Integer, mimdata As String
DoEvents
For ct = 0 To midiInHdr.dwBytesRecorded - 1
If midiInString(ct) <> 247 Then 'not F7 EOX
mimdata = mimdata & Hex(midiInString(ct)) & " "
Else
mimdata = mimdata & Hex(midiInString(ct))
End If
Next ct
sysexIO.lblMidiInRxMsg.Caption = mimdata
If midiInHdr.dwBytesRecorded > 7 Then sysexIO.List1.AddItem (mimdata)
End Function
Qualcuno mi riesce a dare una mano, il mio problema è che attivato in questo modo spesso mi perdo i dati di MidiIn.
Grazie per la collaborazione
Marcello
| 
..
