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