midiout.bas

visual basic课程设计案例精编

Attribute VB_Name = "MidiOut"
Option Explicit

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 midiOutGetNumDevs Lib "winmm" () As Integer
Private Declare Function MIDIOutOpen Lib "winmm.dll" Alias "midiOutOpen" (lphMidiOut As Long, ByVal uDeviceID As Long, ByVal dwCallback As Long, ByVal dwInstance As Long, ByVal dwFlags As Long) As Long
Private Declare Function midiOutClose Lib "winmm.dll" (ByVal hMidiOut As Long) As Long
Private Declare Function midiOutShortMsg Lib "winmm.dll" (ByVal hMidiOut As Long, ByVal dwMsg As Long) As Long
Private Declare Function midiOutGetErrorText Lib "winmm.dll" Alias "midiOutGetErrorTextA" (ByVal err As Long, ByVal lpText As String, ByVal uSize As Long) As Long

Private Const MAXERRORLENGTH = 128       '  max error text length (including NULL)

Private Const MIDIMAPPER = (-1)
Private Const MIDI_MAPPER = (-1)
'MIDIOUTCAPS结构描述了Musical Instrument Digital Interface(MIDI)输入设备的性能
Type MIDIOUTCAPS
    wMid As Integer
    wPid As Integer                ' 产品 ID
    vDriverVersion As Long         ' 设备版本
    szPname As String * 32         ' 设备 name
    wTechnology As Integer         ' 设备类型
    wVoices As Integer
    wNotes As Integer
    wChannelMask As Integer
    dwSupport As Long
End Type

Dim hMidi As Long

Public Function Midi_OutDevsToList(Obj As Control) As Boolean
    Dim i As Integer
    Dim midicaps As MIDIOUTCAPS
    Dim isAdd As Boolean
    
    Obj.Clear
    isAdd = False
    If midiOutGetDevCaps(MIDIMAPPER, midicaps, Len(midicaps)) = 0 Then    '若获取设备信息成功
          Obj.AddItem midicaps.szPname       '添加设备名称
          Obj.ItemData(Obj.NewIndex) = MIDIMAPPER   '这是默认设备ID  = -1
          isAdd = True
    End If
        '添加其他设备
    For i = 0 To midiOutGetNumDevs() - 1
        If midiOutGetDevCaps(i, midicaps, Len(midicaps)) = 0 Then
          Obj.AddItem midicaps.szPname
          Obj.ItemData(Obj.NewIndex) = i
          isAdd = True
        End If
    Next
    Midi_OutDevsToList = isAdd
End Function
Public Function MIDI_OutOpen(ByVal dev_id As Integer) As Integer
Dim midi_error As Integer

    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 Integer

    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(ch As Integer, ByVal kk As Integer, v As Integer)
    Call midi_outshort(&H90 + ch, kk, v)
End Sub

Public Sub note_off(ch As Integer, ByVal kk As Integer)
    Call midi_outshort(&H80 + ch, kk, 0)
End Sub

Sub midi_outshort(b1 As Integer, b2 As Integer, b3 As Integer)
Dim midi_error As Integer

    midi_error = midiOutShortMsg(hMidi, b3 * &H10000 + b2 * &H100 + b1)
    If Not midi_error = 0 Then
        Call midi_outerr(midi_error)
    End If
End Sub
Sub program_change(ch As Integer, cc0nr As Integer, ByVal pnr As Integer)
    Call control_change(ch, 0, cc0nr)
    Call midi_outshort(&HC0 + ch, pnr, 0)
End Sub
Sub control_change(ch As Integer, ccnr As Integer, ByVal v As Integer)
    Call midi_outshort(&HB0 + ch, ccnr, v)
End Sub

Sub midisetrpn(ch As Integer, pmsb As Integer, plsb As Integer, msb As Integer, lsb As Integer)
    Call midi_outshort(ch, &H65, pmsb)
    Call midi_outshort(ch, &H64, plsb)
    Call midi_outshort(ch, &H6, msb)
    Call midi_outshort(ch, &H26, lsb)
End Sub
Sub midi_outerr(ByVal midi_error As Integer)
Dim s As String
Dim x As Integer

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

End Sub