Imports System.Runtime.InteropServices
 
 
Public Class MIDI_Handler
    Structure MIDIHDR
        Dim lpData As String
        Dim dwBufferLength As Integer
        Dim dwBytesRecorded As Integer
        Dim dwUser As Integer
        Dim dwFlags As Integer
        Dim lpNext As Integer
        Dim Reserved As Integer
        Dim dwOffset As Integer
        <VBFixedArray(4)> Dim dwReserved() As Integer
        Public Sub Initialize()
            ReDim dwReserved(4)
        End Sub
    End Structure
 
    Structure MIDIMSG
        Dim MIDIStatus As Byte
        Dim MIDIByte1 As Byte
        Dim MIDIByte2 As Byte
        Dim Garbage As Byte
    End Structure
    Public MidiMessage As MIDIMSG
    Public Bytes(3) As Byte
    Public Const MMSYSERR_BASE As Short = 0
    Public Const MMSYSERR_NOERROR As Short = 0 '  no error
 
    Declare Function midiInGetErrorText Lib "winmm.dll" Alias _
      "midiInGetErrorTextA" ( _
        ByVal err_Renamed As Integer, _
        ByVal lpText As String, _
        ByVal uSize As Integer) _
        As Integer
 
    Declare Function midiInAddBuffer Lib "winmm.dll" ( _
        ByVal hMidiIN As IntPtr, _
        ByRef lpMidiInHdr As MIDIHDR, _
        ByVal uSize As Integer) _
        As Integer
 
    Declare Function midiInPrepareHeader Lib "winmm.dll" ( _
        ByVal hMidiIN As IntPtr, _
        ByRef lpMidiInHdr As MIDIHDR, _
        ByVal uSize As Integer) _
        As Integer
 
 
    Declare Function midiInOpen Lib "winmm.dll" ( _
        ByRef lphMidiIn As IntPtr, _
        ByVal devIDIn As Integer, _
        ByVal cbfuncIn As test, _
        ByVal cbdataIn As Integer, _
        ByVal cboptionsIn As Integer) _
        As Integer
 
    Declare Function midiInClose Lib "winmm.dll" ( _
        ByVal hMidiIN As Integer) _
        As Integer
 
    Declare Function midiInStart Lib "winmm.dll" ( _
        ByVal hMidiIN As IntPtr) _
        As Integer
 
    Declare Function midiInGetNumDevs Lib "winmm.dll" () _
        As Integer
 
    Public Const CALLBACK_FUNCTION = &H30000
    Public Const MM_MIM_OPEN = &H3C1
    Public Const MM_MIM_CLOSE = &H3C2
    Public Const MM_MIM_DATA = &H3C3
    Private Const MIDI_IO_STATUS = &H20&
 
    Public MidiLocation As IntPtr
 
    Public Delegate Function test( _
        ByVal hmidiIn As IntPtr, _
        ByVal wMsg As UInteger, _
        ByVal dwInstance As IntPtr, _
        ByVal dwParam1 As IntPtr, _
        ByVal dwParam2 As IntPtr) As Boolean
 
    Public Function MidiInProc( _
        ByVal hmidiIn As IntPtr, _
        ByVal wMsg As Integer, _
        ByVal dwInstance As IntPtr, _
        ByVal dwParam1 As IntPtr, _
        ByVal dwParam2 As IntPtr) As Boolean
 
        'Debug.Print("wMsg: " & wMsg)
        'Debug.Print("dwInstance: " & dwInstance)
        Debug.Print("dwParam1 (message): " & dwParam1.ToInt32)
        Debug.Print("dwParam2 (Timestamp): " & dwParam2.ToInt32)
 
 
        Bytes = BitConverter.GetBytes(dwParam1.ToInt32)
        MidiMessage.MIDIStatus = Bytes(0)
        MidiMessage.MIDIByte1 = Bytes(1)
        MidiMessage.MIDIByte2 = Bytes(2)
 
        Debug.Print("MIDI Status:" & MidiMessage.MIDIStatus)
        Debug.Print("MIDI Byte 1:" & MidiMessage.MIDIByte1)
        Debug.Print("MIDI Byte 2:" & MidiMessage.MIDIByte2)
 
    End Function
 
 
 
    Public Sub OpenMIDI()
        Dim rcin As Integer
        Dim rc2 As Integer
        Dim intTotalDevIDs As Integer
        Dim devID As Integer = 0
        intTotalDevIDs = midiInGetNumDevs()
        'rc2 = midiInClose(MidiLocation)
        rcin = midiInOpen(MidiLocation, devID, AddressOf MidiInProc, 0, _
          CALLBACK_FUNCTION)
        rc2 = midiInStart(MidiLocation)
    End Sub
End Class