VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 1  'Persistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "Midi"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit

' Error values for functions used in this sample.
' These error values obtained from the include file mmsystem.h (a vc file).
' A descrption of the system functions in the winmm.dll can be found at
' http://msdn.microsoft.com/ (search for winmm.lib and midi).
' winmm.lib is the Windows Multimedia SDK.
'
'#define MMSYSERR_BASE          0
'#define WAVERR_BASE            32
'#define MIDIERR_BASE           64
'#define TIMERR_BASE            96
'#define JOYERR_BASE            160
'#define MCIERR_BASE            256
'#define MIXERR_BASE            1024

'#define MMSYSERR_NOERROR      0                    /* no error */
'#define MMSYSERR_ERROR        (MMSYSERR_BASE + 1)  /* unspecified error */
'#define MMSYSERR_BADDEVICEID  (MMSYSERR_BASE + 2)  /* device ID out of range */
'#define MMSYSERR_NOTENABLED   (MMSYSERR_BASE + 3)  /* driver failed enable */
'#define MMSYSERR_ALLOCATED    (MMSYSERR_BASE + 4)  /* device already allocated */
'#define MMSYSERR_INVALHANDLE  (MMSYSERR_BASE + 5)  /* device handle is invalid */
'#define MMSYSERR_NODRIVER     (MMSYSERR_BASE + 6)  /* no device driver present */
'#define MMSYSERR_NOMEM        (MMSYSERR_BASE + 7)  /* memory allocation error */
'#define MMSYSERR_NOTSUPPORTED (MMSYSERR_BASE + 8)  /* function isn't supported */
'#define MMSYSERR_BADERRNUM    (MMSYSERR_BASE + 9)  /* error value out of range */
'#define MMSYSERR_INVALFLAG    (MMSYSERR_BASE + 10) /* invalid flag passed */
'#define MMSYSERR_INVALPARAM   (MMSYSERR_BASE + 11) /* invalid parameter passed */
'#define MMSYSERR_HANDLEBUSY   (MMSYSERR_BASE + 12) /* handle being used */
'                                                   /* simultaneously on another */
'                                                   /* thread (eg callback) */
'#define MMSYSERR_INVALIDALIAS (MMSYSERR_BASE + 13) /* specified alias not found */
'#define MMSYSERR_BADDB        (MMSYSERR_BASE + 14) /* bad registry database */
'#define MMSYSERR_KEYNOTFOUND  (MMSYSERR_BASE + 15) /* registry key not found */
'#define MMSYSERR_READERROR    (MMSYSERR_BASE + 16) /* registry read error */
'#define MMSYSERR_WRITEERROR   (MMSYSERR_BASE + 17) /* registry write error */
'#define MMSYSERR_DELETEERROR  (MMSYSERR_BASE + 18) /* registry delete error */
'#define MMSYSERR_VALNOTFOUND  (MMSYSERR_BASE + 19) /* registry value not found */
'#define MMSYSERR_NODRIVERCB   (MMSYSERR_BASE + 20) /* driver does not call DriverCallback */
'#define MMSYSERR_MOREDATA     (MMSYSERR_BASE + 21) /* more data to be returned */
'#define MMSYSERR_LASTERROR    (MMSYSERR_BASE + 21) /* last error in range */


'User-defined variable the stores information about the MIDI output device.
'below is a VB representation of the C structure defined on MSDN.
'see http://msdn.microsoft.com/library/default.asp?url=/library/en-us/multimed/htm/_win32_midioutcaps_str.asp

Const MAXPNAMELEN = 32              ' Maximum product name length

Private Type MIDIOUTCAPS
    wMid As Integer
    wPid As Integer
    vDriverVersion As Long
    szPname As String * MAXPNAMELEN
    wTechnology As Integer
'/* flags for wTechnology field of MIDIOUTCAPS structure */
'#define MOD_MIDIPORT    1  /* output port */
'#define MOD_SYNTH       2  /* generic internal synth */
'#define MOD_SQSYNTH     3  /* square wave internal synth */
'#define MOD_FMSYNTH     4  /* FM internal synth */
'#define MOD_MAPPER      5  /* MIDI mapper */
'#define MOD_WAVETABLE   6  /* hardware wavetable synth */
'#define MOD_SWSYNTH     7  /* software synth */
    wVoices As Integer
    wNotes As Integer
    wChannelMask As Integer
    dwSupport As Long
'/* flags for dwSupport field of MIDIOUTCAPS structure */
'#define MIDICAPS_VOLUME          0x0001  /* supports volume control */
'#define MIDICAPS_LRVOLUME        0x0002  /* separate left-right volume control */
'#define MIDICAPS_CACHE           0x0004
'#define MIDICAPS_STREAM          0x0008  /* driver supports midiStreamOut directly */

End Type

' the following are VB wrapper functions to access the system midi functions in the winmm.dll
' additional information on each of these functions can be found by searching for the function name at
' http://msdn.microsoft.com
Private Declare Function midiOutGetNumDevs Lib "winmm.dll" () As Integer

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 midiOutClose Lib "winmm.dll" (ByVal hMidiOut As Long) As Long

Private 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

Private Declare Function midiOutShortMsg Lib "winmm.dll" (ByVal hMidiOut As Long, ByVal dwMsg As Long) As Long

' ************************************************************************
' Active X interface functions below.
' Each of the MIDIOUTCAPS items is accessed via a property.

' Global variables
Dim midicaps As MIDIOUTCAPS ' holds the capability of the MIDI device.
Dim hMidi As Long ' handle to the midi device. Only support single device.

Public Property Get OutNumDevs()
    OutNumDevs = midiOutGetNumDevs()
End Property

Public Function LoadOutDevCaps(id)
    LoadOutDevCaps = midiOutGetDevCaps(id, midicaps, Len(midicaps))
End Function

Public Property Get ProdName()
    ProdName = midicaps.szPname
End Property

Public Property Get ManufId()
    ManufId = midicaps.wMid
End Property

Public Property Get ProdId()
   ProdId = midicaps.wPid
End Property

Public Property Get DriverVers()
   DriverVers = midicaps.vDriverVersion
End Property
Public Property Get Technology()
   Technology = midicaps.wTechnology
End Property

Public Property Get Voices()
   Voices = midicaps.wVoices
End Property
                                     
Public Property Get Notes()
    Notes = midicaps.wNotes
End Property
                                     
Public Property Get ChannelMask()
   ChannelMask = midicaps.wChannelMask
End Property
                                     
Public Property Get SupportMask()
   SupportMask = midicaps.dwSupport
End Property

Public Function OutOpen(DeviceID)
    Call midiOutClose(hMidi)  ' close if already open
    OutOpen = midiOutOpen(hMidi, DeviceID, 0, 0, 0)
End Function

Public Function OutClose()
    OutClose = midiOutClose(hMidi)
End Function

Public Function OutShortMessage(Msg)
    OutShortMessage = midiOutShortMsg(hMidi, Msg)
End Function

Public Function NoteStart(channel, note, Velocity) As String
' turn note on. simpler than calling OutShortMessage
    Dim Msg
    
    If channel < 0 Or channel > 15 Then
        NoteStart = "Bad channel number: " + channel
        Return
    End If
    
    If note < 0 Or note > 127 Then
        NoteStart = "Bad note: " + note
        Return
    End If
    
    If Velocity < 0 Or Velocity > 127 Then
        NoteStart = "Bad velocity: " + Velocity
        Return
    End If
    
    Msg = &H90 + ((note) * &H100) + (Velocity * &H10000) + channel
    NoteStart = midiOutShortMsg(hMidi, Msg)
End Function

Public Function NoteStop(channel, note) As String
' turn note off. simpler than calling OutShortMessage
    Dim Msg
    
    If channel < 0 Or channel > 15 Then
        NoteStop = "Bad channel number: " + channel
        Return
    End If
    
    If note < 0 Or note > 127 Then
        NoteStop = "Bad note: " + note
        Return
    End If

    Msg = &H80 + ((note) * &H100) + channel
    NoteStop = midiOutShortMsg(hMidi, Msg)
End Function

Public Function Patch(channel, voice) As String
' Patch voice to channel. simpler than calling OutShortMessage
    Dim Msg
    
    If channel < 0 Or channel > 15 Then
        Patch = "Bad channel number: " + channel
        Return
    End If
    
    If voice < 0 Or voice > 127 Then
        Patch = "Bad voice number: " + voice
        Return
    End If
    
    Msg = &HC0 + ((voice) * &H100) + channel
    Patch = midiOutShortMsg(hMidi, Msg)
End Function

Public Function PatchBank(bank) As String
' Patch 16 voices to channels. simpler than calling Patch multiple times.
    Dim base
    Dim i, Msg
    If bank < 0 Or bank > 7 Then
        PatchBank = "bad bank number: " + bank
        Return
    End If
    base = bank * 16 ' calculate base value
    For i = 0 To 15
        Call Patch(i, base + i)
    Next i
    PatchBank = "OK"
End Function

