SysEx Problem |
Hello, I have problems sending SysEx (Midi long messages) to my sound module (SC-55 extern). This I am trying to do in Visual Basic 5 and the used PC soundcard is a simple Aztek Sound Galaxy (azt16w.dll). My sound module recieves the messages, but the driver (winmm.dll?) doesn't remove the message from the message queque. In other words the dwFlags in the MIDIHDR isn't set to MHDR_DONE, as espected. So after sending the message, I cannot use the midiOutUnprepareHeader function, without forcing it by setting the flags to MHDR_DONE myself. As long as I only want to send SysEx DataSet, this works, but when I also want to send a SysEx Data Request I have to solve the problem. When I use the midiOutProc callback function, I receive the MM_MOM_DONE message, but then my sc55 doesn't receive the SysEx. When I use midiOutReset the dwFlags in the MIDIHDR is also not set to MHDR_DONE as espected. Where's the problem? Am I doing something wrong? Below, some code, to show what I do (place it in a vb module, and call the SendSyxEx routine) ... Thanks for helping me. Stefaan Casier Email:stefaan.casier@pi.be |
Option Explicit
Public hMidiOUT As Long
Public mMPU401OUT As Long
Public Const MAXPNAMELEN = 32 ' max product name length (including NULL)
Public Const MMSYSERR_NOERROR = 0 ' no error
' flags for dwFlags field of MIDIHDR structure
Public Const MHDR_DONE = &H1 ' done bit
Public Const MHDR_PREPARED = &H2 ' set if header prepared
Public Const MHDR_INQUEUE = &H4 ' reserved for driver
Public Const MHDR_VALID = &H7 ' valid flags / ;Internal /
' flags used with midiOutOpen() to specify the type of the dwCallback parameter.
Public Const CALLBACK_NULL = &H0 ' no callback
Public Const CALLBACK_WINDOW = &H10000 ' dwCallback is a HWND
Public Const CALLBACK_FUNCTION = &H30000 ' dwCallback is a FARPROC
Type MIDIHDR
lpData As String
dwBufferLength As Long
dwBytesRecorded As Long
dwUser As Long
dwFlags As Long
lpNext As Long
Reserved As Long
End Type
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
Declare Function midiOutClose Lib "winmm.dll" (ByVal hMidiOUT As Long) As Long
Declare Function midiOutGetDevCaps Lib "winmm.dll" Alias "midiOutGetDevCapsA" (ByVal uDeviceID As Long, lpCaps As MIDIOUTCAPS, ByVal uSize As Long) As Long
Declare Function midiOutGetErrorText Lib "winmm.dll" Alias "midiOutGetErrorTextA" (ByVal err As Long, ByVal lpText As String, ByVal uSize As Long) As Long
Declare Function midiOutGetNumDevs Lib "winmm" () As Integer
Declare Function midiOutLongMsg Lib "winmm.dll" (ByVal hMidiOUT As Long, lpMidiOutHdr As MIDIHDR, ByVal uSize As Long) As Long
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
Declare Function midiOutPrepareHeader Lib "winmm.dll" (ByVal hMidiOUT As Long, lpMidiOutHdr As MIDIHDR, ByVal uSize As Long) As Long
Declare Function midiOutUnprepareHeader Lib "winmm.dll" (ByVal hMidiOUT As Long, lpMidiOutHdr As MIDIHDR, ByVal uSize As Long) As Long
Declare Function midiOutReset Lib "winmm.dll" (ByVal hMidiOUT As Long) As Long
' looking for the right device ID (Roland MPU-401)
Private Function FindMPU401OUT() As Boolean
Dim I As Integer
Dim NumDevsOut As Integer
Dim Name As String
Dim DevO As MIDIOUTCAPS
Dim midiError As Long
NumDevsOut = midiOutGetNumDevs()
For I = 0 To NumDevsOut - 1
midiError = midiOutGetDevCaps(I, DevO, 52)
If midiError <> MMSYSERR_NOERROR Then
ShowMMerr "midiOutGetDevCaps", midiError
Exit Function
End If
Name = Left(DevO.szPname, InStr(1, DevO.szPname, Chr(0)) - 1)
If InStr(1, Name, "MPU-401") > 0 Then
mMPU401OUT = I
FindMPU401OUT = True
Exit For
End If
Next I
End Function
' making the SyxEx message for SC55
Private Function makeComStr(ByVal Address As String, ByVal value As Long) As String
Dim I As Long
Dim B(10) As Byte, data As String
B(0) = &HF0
B(1) = &H41 ' ManuID roland
B(2) = &H10 ' DeviceID
B(3) = &H42 ' GS
B(4) = &H12 ' data set 1
B(5) = Val("&H" & Left(Address, 2))
B(6) = Val("&H" & Mid(Address, 3, 2))
B(7) = Val("&H" & Right(Address, 2))
B(8) = value
B(9) = 0 ' checksum
B(10) = &HF7
' make checksum
For I = 5 To 8: B(9) = CByte((CInt(B(9)) + CInt(B(I))) Mod 255): Next I
B(9) = -B(9) And 127
' make data string
For I = 0 To 10: data = data & Chr(B(I)): Next I
makeComStr = data
End Function
Public Sub SendSyxEx()
Dim midiError As Long
Dim mh As MIDIHDR
Dim mTime As Single, Timeout As Boolean
FindMPU401OUT
If hMidiOUT = 0 Then
midiError = midiOutOpen(hMidiOUT, mMPU401OUT, 0, 0, CALLBACK_NULL)
If midiError <> MMSYSERR_NOERROR Then
ShowMMerr "midiOutOpen", midiError
Exit Sub
End If
End If
mh.lpData = makeComStr("400004", 111) ' set master volume to 111
mh.dwBufferLength = Len(mh.lpData)
mh.dwFlags = 0
midiError = midiOutPrepareHeader(hMidiOUT, mh, 24 + mh.dwBufferLength)
If midiError <> MMSYSERR_NOERROR Then
ShowMMerr "midiOutPrepareHeader", midiError
Else
midiError = midiOutLongMsg(hMidiOUT, mh, 24 + mh.dwBufferLength)
If midiError <> MMSYSERR_NOERROR Then
ShowMMerr "midiOutLongMsg", midiError
Else
' normaly the code here should be
'
' While mh.dwFlags <> MHDR_DONE: DoEvents: Wend
'
' since the mh.dwFlags isn't set to MHDR_DONE by the driver
' I wait and set it myself
'
mTime = Timer: Timeout = False
While mh.dwFlags <> MHDR_DONE And Timeout = False
If Timer - mTime > 0.5 Then Timeout = True
DoEvents
Wend
If Timeout = True Then mh.dwFlags = MHDR_DONE
End If
midiError = midiOutUnprepareHeader(hMidiOUT, mh, 24 + mh.dwBufferLength)
If midiError <> MMSYSERR_NOERROR Then ShowMMerr "midiOutUnprepareHeader", midiError
End If
midiError = midiOutClose(hMidiOUT)
If midiError <> MMSYSERR_NOERROR Then ShowMMerr "midiOutClose", midiError
End Sub
Private Sub ShowMMerr(ByVal ErrIn As String, ByVal MMerr As Long)
Dim msg As String
msg = String(255, " ")
midiOutGetErrorText MMerr, msg, 255
MsgBox msg, vbOKOnly, ErrIn
End Sub