Attribute VB_Name = "mdlMidiOut"
'=======================
' 作者：吳文成
'=======================

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.dll" () As Integer
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 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 = 256
Private Const midiDefault = -1              '預設的 Midi 設備代碼
Private Const MIDI_EVENT_NOTE_ON = &H90     '=144，設定開始播放的旗標
Private Const MIDI_EVENT_NOTE_OFF = &H80    '=128，設定停止播放的旗標
Private Const MIDI_STOP_ALL_NOTES = &HB0    '=176，設定所有播放停止的旗標
Private Const MIDI_CHANGE_ALL_NOTES = &HC0  '=192，設定改變所有播放音調的旗標

'描述 Midi 設備的結構
Private Type MidiOutCaps
  wMid As Integer
  wPid As Integer
  vDriverVersion As Long  ' 設備版本
  szPname As String * 32  ' 設備名稱
  wTechnology As Integer  ' 設備類型
  wVoices As Integer
  wNotes As Integer
  wChannelMask As Integer
  dwSupport As Long
End Type

Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public velocityBase As Long, noteBase As Long

Private hMidi As Long, midiErr As Long

'取得所有的與預設的 Midi 輸出設備
Public Function midiDevToList(obj As Control) As Boolean
  Dim i As Integer, midiCaps As MidiOutCaps
  
  obj.Clear
  If midiOutGetDevCaps(midiDefault, midiCaps, Len(midiCaps)) = 0 Then
    '如果取得 Midi 設備成功，則先加入預設的設備名稱
    obj.AddItem midiCaps.szPname
    obj.ItemData(obj.NewIndex) = midiDefault   '預設的 Midi 設備代碼
    midiDevToList = True
  End If
  '在取得預設的 Midi 設備之後，再取得其他的 Midi 設備
  For i = 0 To midiOutGetNumDevs - 1
    If midiOutGetDevCaps(i, midiCaps, Len(midiCaps)) = 0 Then
      obj.AddItem midiCaps.szPname
      obj.ItemData(obj.NewIndex) = i
      midiDevToList = True
    End If
  Next
End Function

'以指定參數，改變 Midi 輸出設備
Public Sub midiChangeDev(ByVal devId As Long)
  midiClose
  '以指定之 Midi 設備代碼，開啟 Midi 設備，同時取得 hMidi
  midiErr = midiOutOpen(hMidi, devId, 0, 0, 0)
  If midiErr <> 0 Then midiErrMsg midiErr
End Sub

'關閉正在使用的 Midi 輸出設備
Public Sub midiClose()
  If hMidi <> 0 Then
    midiErr = midiOutClose(hMidi)
    If midiErr <> 0 Then midiErrMsg midiErr
    hMidi = 0
  End If
End Sub

'以指定參數，播放 Midi 音符
'參數分別為通道編號，音調，速度（「速度」相對控制了播放音量與播放時間）
Public Sub keyOn(channel As Long, ByVal note As Long, ByVal velocity As Long)
  On Error Resume Next

  'frmExtraMidi.cmdKey(note).BackColor = vbRed
  midiPlay MIDI_EVENT_NOTE_ON + channel, note + noteBase, velocity
End Sub

'停止前一次的 Midi 音符播放
Public Sub keyOff(channel As Long, ByVal note As Long)
  On Error Resume Next
  
  'frmExtraMidi.cmdKey(note).BackColor = vbButtonFace
  'velocity = 0
  midiPlay MIDI_EVENT_NOTE_OFF + channel, note + noteBase, 0
End Sub

'向 Midi 輸出設備發送短訊息
Private Sub midiPlay(channel As Long, note As Long, velocity As Long)
  midiErr = midiOutShortMsg(hMidi, channel + note * &H100 + velocity * &H10000)
  If midiErr <> 0 Then midiErrMsg midiErr
End Sub

'以指定參數，改變演奏樂器
Public Sub midiChangeSound(channel As Long, ByVal noteSound As Long)
  midiPlay MIDI_STOP_ALL_NOTES + channel, 0, 0
  midiPlay MIDI_CHANGE_ALL_NOTES + channel, noteSound, 0
End Sub

'取得 Midi 輸出設備的錯誤訊息
Private Sub midiErrMsg(ByVal midiErr As Long)
  Dim s As String, d As Long

  s = String(maxErrorLength, 0)
  d = midiOutGetErrorText(midiErr, s, maxErrorLength)
  MsgBox s
End Sub



