midiout.vb

这是一本用Visual Studio.NET进行多媒体编程的读物

Option Strict Off
Option Explicit On
Module MidiOut
	Private Declare Function midiOutGetDevCaps Lib "winmm.dll"  Alias "midiOutGetDevCapsA"(ByVal uDeviceID As Integer, ByRef lpCaps As MIDIOUTCAPS, ByVal uSize As Integer) As Integer
	Private Declare Function midiOutGetNumDevs Lib "winmm" () As Short
	Private Declare Function MIDIOutOpen Lib "winmm.dll"  Alias "midiOutOpen"(ByRef lphMidiOut As Integer, ByVal uDeviceID As Integer, ByVal dwCallback As Integer, ByVal dwInstance As Integer, ByVal dwFlags As Integer) As Integer
	Private Declare Function midiOutClose Lib "winmm.dll" (ByVal hMidiOut As Integer) As Integer
	Private Declare Function midiOutShortMsg Lib "winmm.dll" (ByVal hMidiOut As Integer, ByVal dwMsg As Integer) As Integer
	Private Declare Function midiOutGetErrorText Lib "winmm.dll"  Alias "midiOutGetErrorTextA"(ByVal err_Renamed As Integer, ByVal lpText As String, ByVal uSize As Integer) As Integer
	
	Private Const MAXERRORLENGTH As Short = 128 '  max error text length (including NULL)
	
	Private Const MIDIMAPPER As Short = (-1)
    Private Const MIDI_MAPPER As Short = (-1)

	'MIDIOUTCAPS结构描述了Musical Instrument Digital Interface(MIDI)输入设备的性能
	Structure MIDIOUTCAPS
		Dim wMid As Short
		Dim wPid As Short
		Dim vDriverVersion As Integer
		<VBFixedString(32),System.Runtime.InteropServices.MarshalAs(System.Runtime.InteropServices.UnmanagedType.ByValTStr,SizeConst:=32)> Dim szPname As String
		Dim wTechnology As Short
		Dim wVoices As Short
		Dim wNotes As Short
		Dim wChannelMask As Short
		Dim dwSupport As Integer
	End Structure
	
	Dim hMidi As Integer
	
    Public Function Midi_OutDevsToList(ByRef Obj As System.Windows.Forms.ComboBox) As Boolean
        Dim i As Short
        Dim midicaps As MIDIOUTCAPS
        Dim isAdd As Boolean
        Dim x As Integer

        Obj.Items.Clear()
        isAdd = False
        If midiOutGetDevCaps(MIDIMAPPER, midicaps, Len(midicaps)) = 0 Then '若获取设备信息成功
            x = Obj.Items.Add(midicaps.szPname) '添加设备名称            
            VB6.SetItemData(Obj, x, MIDIMAPPER) '这是默认设备ID  = -1
            isAdd = True
        End If

        '添加其他设备

        For i = 0 To midiOutGetNumDevs() - 1
            If midiOutGetDevCaps(i, midicaps, Len(midicaps)) = 0 Then
                x = Obj.Items.Add(midicaps.szPname)
                VB6.SetItemData(Obj, x, i)
                isAdd = True
            End If
        Next
        Midi_OutDevsToList = isAdd
    End Function
    Public Function MIDI_OutOpen(ByVal dev_id As Short) As Short
        Dim midi_error As Short

        midi_OutClose()
        midi_error = MIDIOutOpen(hMidi, dev_id, 0, 0, 0)
        If Not midi_error = 0 Then
            Call midi_outerr(midi_error)
        End If
        MIDI_OutOpen = (hMidi <> 0)
    End Function
    Public Sub midi_OutClose()
        Dim midi_error As Short

        If hMidi <> 0 Then
            midi_error = midiOutClose(hMidi)
            If Not midi_error = 0 Then
                Call midi_outerr(midi_error)
            End If
            hMidi = 0
        End If
    End Sub
    Public Sub note_on(ByRef ch As Short, ByVal kk As Short, ByRef v As Short)
        Call midi_outshort(&H90S + ch, kk, v)
    End Sub

    Public Sub note_off(ByRef ch As Short, ByVal kk As Short)
        Call midi_outshort(&H80S + ch, kk, 0)
    End Sub

    Sub midi_outshort(ByRef b1 As Short, ByRef b2 As Short, ByRef b3 As Short)
        Dim midi_error As Short

        midi_error = midiOutShortMsg(hMidi, b3 * &H10000 + b2 * &H100S + b1)
        If Not midi_error = 0 Then
            Call midi_outerr(midi_error)
        End If
    End Sub
    Sub program_change(ByRef ch As Short, ByRef cc0nr As Short, ByVal pnr As Short)
        Call control_change(ch, 0, cc0nr)
        Call midi_outshort(&HC0S + ch, pnr, 0)
    End Sub
    Sub control_change(ByRef ch As Short, ByRef ccnr As Short, ByVal v As Short)
        Call midi_outshort(&HB0S + ch, ccnr, v)
    End Sub

    Sub midisetrpn(ByRef ch As Short, ByRef pmsb As Short, ByRef plsb As Short, ByRef msb As Short, ByRef lsb As Short)
        Call midi_outshort(ch, &H65S, pmsb)
        Call midi_outshort(ch, &H64S, plsb)
        Call midi_outshort(ch, &H6S, msb)
        Call midi_outshort(ch, &H26S, lsb)
    End Sub
    Sub midi_outerr(ByVal midi_error As Short)
        Dim s As String
        Dim x As Short

        s = Space(MAXERRORLENGTH)
        x = midiOutGetErrorText(midi_error, s, MAXERRORLENGTH)
        MsgBox(s)

    End Sub
End Module