ＭＩＤＩの入力を受信−ＭＩＤＩモニター
|
Option Explicit
Private Type MIDIHDR
lpData As Long
dwBufferLength As Long
dwBytesRecorded As Long
dwUser As Long
dwFlags As Long
lpNext As Long
reserved As Long
dwOffset As Long
Rev(3) As Long
End Type
Private Const MAXPNAMELEN = 32
Private Type MIDIINCAPS
wMid As Integer
wPid As Integer
vDriverVersion As Long
szPname As String * MAXPNAMELEN
End Type
Private Declare Function midiInGetNumDevs Lib "winmm.dll" () As Long
Private Declare Function midiInGetDevCaps Lib "winmm.dll" Alias "midiInGetDevCapsA" (ByVal uDeviceID As Long, lpCaps As MIDIINCAPS, ByVal uSize As Long) As Long
Private Declare Function midiInAddBuffer Lib "winmm.dll" (ByVal hMidiIn As Long, lpMidiInHdr As MIDIHDR, ByVal uSize As Long) As Long
Private Declare Function midiInClose Lib "winmm.dll" (ByVal hMidiIn As Long) As Long
Private Declare Function midiInOpen Lib "winmm.dll" (lphMidiIn As Long, ByVal uDeviceID As Long, ByVal dwCallback As Long, ByVal dwInstance As Long, ByVal dwFlags As Long) As Long
Private Declare Function midiInPrepareHeader Lib "winmm.dll" (ByVal hMidiIn As Long, lpMidiInHdr As MIDIHDR, ByVal uSize As Long) As Long
Private Declare Function midiInReset Lib "winmm.dll" (ByVal hMidiIn As Long) As Long
Private Declare Function midiInStart Lib "winmm.dll" (ByVal hMidiIn As Long) As Long
Private Declare Function midiInStop Lib "winmm.dll" (ByVal hMidiIn As Long) As Long
Private Declare Function midiInUnprepareHeader Lib "winmm.dll" (ByVal hMidiIn As Long, lpMidiInHdr As MIDIHDR, ByVal uSize As Long) As Long
Private hMidi As Long 'MIDIINハンドル
Private typMIDIHDR As MIDIHDR
Private MidiInBuffer(32) As Byte 'LONGメッセージ受信バッファ
Public Enum GetMsgCode
MIDIIN_GET_SHORTMSG = 0 'ショートメッセージを受信
MIDIIN_hMIDI_ERROR = 1 '別のMIDIINデバイスのMSGを受信
MIDIIN_LENGTH_ERROR = 2 'UserBufferのサイズが小さい
MIDIIN_OTHER_ERROR = 3 '予期しないエラー
MIDIIN_GET_LONGMSG = 0 'ロングメッセージを受信
End Enum
Private Const CALLBACK_WINDOW = &H10000 'dwCallback is a HWND
Private Const CALLBACK_FUNCTION = &H30000 'dwCallback is a FARPROC
'MIDIIN ウィンドウメッセージ定義
Public Const MM_MIM_OPEN = &H3C1
Public Const MM_MIM_CLOSE = &H3C2
Public Const MM_MIM_DATA = &H3C3
Public Const MM_MIM_LONGDATA = &H3C4
Public Const MM_MIM_ERROR = &H3C5
Public Const MM_MIM_LONGERROR = &H3C6
Declare Function SetWindowLong Lib "user32" _
Alias "SetWindowLongA" _
(ByVal hWnd As Long, ByVal nIndex As Long, _
ByVal dwNewLong As Long) As Long
Public Const GWL_WNDPROC = (-4)
Declare Function CallWindowProc Lib "user32" _
Alias "CallWindowProcA" _
(ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, _
ByVal msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private oldProc As Long
Private TargetHwnd As Long
'******************************************************************
'プロシージャ名: :OpenMidiIn
'説明: :MIDI入力受信の準備を行います。
'引数: :lngDeviceID MIDI入力デバイスの識別ID
' :hWnd コールバックメッセージを受信するウィンドウハンドル
'戻り値 :Boolean型
'******************************************************************
Public Function OpenMidiIn(lngDeviceID As Long, hWnd As Long) As Boolean
Dim lngRC As Long 'リターンコード
'戻値の初期値を設定
OpenMidiIn = False
'パラメタの検定
If hMidi <> 0 Then Exit Function
If hWnd = 0 Then Exit Function
'メッセージを受信するためサブクラス化を行う
subClassStart hWnd
'MIDIINのオープン
lngRC = midiInOpen(hMidi, lngDeviceID, hWnd, &H0, CALLBACK_WINDOW)
If lngRC = 0 Then
OpenMidiIn = True
Else
OpenMidiIn = False
End If
End Function
'******************************************************************
'プロシージャ名: :StartMidiIn
'説明: :MIDI入力受信を開始する。
'引数: :なし
'戻り値 :Boolean型
'******************************************************************
Public Function StartMidiIn() As Boolean
Dim lngRC As Long 'リターンコード
'戻り値初期化
StartMidiIn = False
'ロングメッセージ取得用バッファ設定
If ADDLongMsgBuff = False Then Exit Function
'MIDIINスタート
lngRC = midiInStart(hMidi)
If lngRC <> 0 Then Exit Function
StartMidiIn = True
End Function
'******************************************************************
'プロシージャ名: :CloseMidiIn
'説明: :MIDI入力受信を停止する
'引数: :なし
'戻り値 :Boolean型
'******************************************************************
Public Function CloseMidiIn() As Boolean
Dim lngRC As Long
Dim FlgErr As Boolean
FlgErr = False
If hMidi = 0 Then Exit Function
CloseMidiIn = False
'入力をリセット
lngRC = midiInReset(hMidi)
If lngRC <> 0 Then FlgErr = True
'停止
lngRC = midiInStop(hMidi)
If lngRC <> 0 Then FlgErr = True
'ロングメッセージ受信用のヘッダを破棄する
lngRC = midiInUnprepareHeader(hMidi, typMIDIHDR, LenB(typMIDIHDR))
If lngRC <> 0 Then FlgErr = True
'入力デバイスを閉じる
lngRC = midiInClose(hMidi)
If lngRC <> 0 Then FlgErr = True
'途中でエラーにならなければ、戻り値をTrueにする
If FlgErr = False Then
CloseMidiIn = True
hMidi = 0
End If
'サブクラス化の解除を行う
subClassEnd
End Function
'******************************************************************
'プロシージャ名: :GetMidiShortMsg
'説明: :ウィンドウプロシージャのパラメタからMIDIショートメッセージを取得する
'引数: :wParam ウィンドウプロシージャのwParam
' :lParam ウィンドウプロシージャのlParam
' :bytShortMsg 受信したショートメッセージのバイト配列（0〜2）
'戻り値 :GetMsgCode型
'******************************************************************
Public Function GetMidiShortMsg(wParam As Long, lParam As Long, bytShortMsg() As Byte) As GetMsgCode
Dim lngRC As Long
Dim intHiWord As Integer, intLowWord As Integer
Dim bytNULL As Byte
'戻り値の初期化
GetMidiShortMsg = MIDIIN_GET_SHORTMSG
'別のMIDIINデバイスからの入力の場合
If wParam <> hMidi Then
'MIDIデバイスハンドルエラーを返す
GetMidiShortMsg = MIDIIN_hMIDI_ERROR
Exit Function
End If
'ダブルワード→上位ワード、下位ワードに分割
Call DWordToWord(lParam, intHiWord, intLowWord)
'下位ワード→データバイト１、ステータスバイトに分割
Call WordToByte(intLowWord, bytShortMsg(1), bytShortMsg(0))
'上位ワード→ バイト、データバイト２に分割
Call WordToByte(intHiWord, bytNULL, bytShortMsg(2))
End Function
'******************************************************************
'プロシージャ名: :GetMidiLongMsg
'説明: :直前に受信したロングメッセージを取得する
'引数: :bytUserBuffer ロングメッセージを格納するバイト配列
' :lngBuffSize バッファ領域のサイズ、受信したロングメッセージのサイズ
'戻り値 :GetMsgCode型
'******************************************************************
Public Function GetMidiLongMsg(bytUserBuffer() As Byte, lngBuffSize As Long) As GetMsgCode
Dim lngCount As Long
'受信したサイズがバッファのサイズより大きい場合
If typMIDIHDR.dwBytesRecorded - 1 > lngBuffSize Then
'バッファサイズエラーを返す
GetMidiLongMsg = MIDIIN_LENGTH_ERROR
Exit Function
Else
'受信サイズを設定する
lngBuffSize = typMIDIHDR.dwBytesRecorded - 1
End If
'受信領域をコピーする（用途に合わせて修正したほうが好ましい）
For lngCount = 0 To lngBuffSize
bytUserBuffer(lngCount) = MidiInBuffer(lngCount)
Next
End Function
'******************************************************************
'プロシージャ名: :GetMidiInDevice
'説明: :MIDI IN デバイスをコレクションに列挙
'引数: :Device デバイスを格納するコレクション
'******************************************************************
Public Sub GetMidiInDevice(Device As Collection)
Dim lngCount As Long
Dim MaxCount As Long
Dim strBuff As String
Dim lngRC As Long
Dim MidiCaps As MIDIINCAPS
'全MIDI IN デバイスの数を取得
MaxCount = midiInGetNumDevs()
'MIDI出力ﾃﾞﾊﾞｲｽが使用できない場合
If MaxCount <= 0 Then Exit Sub
'一個ずつ、情報を取得
For lngCount = 0 To MaxCount - 1
lngRC = midiInGetDevCaps(lngCount, MidiCaps, Len(MidiCaps))
strBuff = MidiCaps.szPname
strBuff = Left(strBuff, InStr(strBuff, vbNullChar) - 1)
Device.Add strBuff
Next
End Sub
'******************************************************************
'プロシージャ名: :ADDLongMsgBuff（内部関数）
'説明: :'ロングメッセージ取得用バッファを設定
'引数: :なし
'戻り値 :Boolean型
'******************************************************************
Private Function ADDLongMsgBuff() As Boolean
Dim lngRC As Long
ADDLongMsgBuff = False
'Longメッセージ取得用のMIDIHDRを準備する。
With typMIDIHDR
.lpData = VarPtr(MidiInBuffer(0))
.dwBufferLength = UBound(MidiInBuffer)
.dwFlags = &H0
.dwBytesRecorded = &H0
End With
'ヘッダの登録
lngRC = midiInPrepareHeader(hMidi, typMIDIHDR, LenB(typMIDIHDR))
If lngRC <> 0 Then Exit Function
'バッファの追加
lngRC = midiInAddBuffer(hMidi, typMIDIHDR, LenB(typMIDIHDR))
If lngRC <> 0 Then Exit Function
ADDLongMsgBuff = True
End Function
'******************************************************************
'プロシージャ名: :BinToHex（内部関数）
'説明: :バイト配列を文字列に変換する。
'引数: :Bin 変換前のバイト配列
' :lngSize 変換前のバイト配列のサイズ
' :strHex 変換後の文字列（１６進の文字列）
'******************************************************************
Private Sub BinToHex(Bin() As Byte, lngSize As Long, strHex As String)
Dim lngCount As Long
For lngCount = 0 To lngSize
If Bin(lngCount) <= &HF Then
strHex = strHex & "0" & Hex$(Bin(lngCount))
Else
strHex = strHex & Hex$(Bin(lngCount))
End If
Next
End Sub
'******************************************************************
'プロシージャ名: :DWordToWord（内部関数）
'説明: :ダブルワード（３２ビット整数値）を上位・下位ワード（１６ビット整数値）に分ける。
'引数: :DoubleWord ３２ビット整数値
' :HiWord １６ビット整数値の上位
' :LowWord １６ビット整数値の下位
'補足: :VBにはダブルワード型、ワード型の相当する型がないのでLong型、Integer型で代用する。
'******************************************************************
Private Sub DWordToWord(DoubleWord As Long, HiWord As Integer, LowWord As Integer)
If (DoubleWord And &HFFFF&) > &H7FFF Then
LowWord = (DoubleWord And &HFFFF&) - &H10000
Else
LowWord = DoubleWord And &HFFFF&
End If
HiWord = (DoubleWord And &HFFFF0000) \ &H10000
End Sub
'******************************************************************
'プロシージャ名: :WordToByte（内部関数）
'説明: :ワード（１６ビット整数値）を上位・下位バイトに分ける
'引数: :Word １６ビット整数値
' :HiByte 上位バイト
' :LowByte 下位バイト
'補足: :VBにはワード型の相当する型がないのでInteger型で代用する。
'******************************************************************
Private Sub WordToByte(Word As Integer, HiByte As Byte, LowByte As Byte)
LowByte = Word And &HFF
If Word < 0 Then
HiByte = (Word + &H10000) \ &H100
Else
HiByte = Word \ &H100
End If
End Sub
'******************************************************************
'プロシージャ名: :subClassStart（内部関数）
'説明: :サブクラス化を行う
'引数: :lngHwnd ウィンドウハンドル
'******************************************************************
Private Sub subClassStart(lngHwnd As Long)
TargetHwnd = lngHwnd
oldProc = SetWindowLong(TargetHwnd, GWL_WNDPROC, AddressOf WindowProc)
End Sub
'******************************************************************
'プロシージャ名: :subClassEnd（内部関数）
'説明: :サブクラス化の解除
'引数: :なし
'******************************************************************
Private Sub subClassEnd()
If oldProc <> 0 Then
SetWindowLong TargetHwnd, GWL_WNDPROC, oldProc
oldProc = 0
End If
End Sub
'******************************************************************
'プロシージャ名: :WindowProc
'説明: :MIDI入力受信用ウインドウプロシージャ
'引数: :hWnd ウィンドウハンドル
' :uMsg ウィンドウメッセージ
' :wParam ３２ビット整数値
' :lParam ３２ビット整数値
'戻り値 :Long型
'******************************************************************
Public Function WindowProc(ByVal hWnd As Long, ByVal uMsg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long
Dim lngRC As GetMsgCode
Dim strLongMsg As String
Dim bytBuff(32) As Byte, lngSize As Long
Dim bytShortMsg(2) As Byte, strShortMsg As String
'ウィンドウメッセージで処理を分ける
Select Case uMsg
'MIDI IN デバイスがOPENされたとき
Case MM_MIM_OPEN
Form1.List1.AddItem "MIDIIN OPEN"
'MIDIショートメッセージを受信したとき
Case MM_MIM_DATA
'該当デバイスで受信したとき
If GetMidiShortMsg(wParam, lParam, bytShortMsg) = MIDIIN_GET_SHORTMSG Then
'受信したバイト配列を文字列に変換する
Call BinToHex(bytShortMsg, 2, strShortMsg)
'リストボックスに受信メッセージを表示
Form1.List1.AddItem "ShortMsg受信 : " & strShortMsg
End If
'ロングメッセージを受信したとき
Case MM_MIM_LONGDATA
'とりあえず、ロングメッセージの最大サイズを３２とする（意味なし）
lngSize = 32
'受信したロングメッセージをバイト配列にいれる
GetMidiLongMsg bytBuff, lngSize
'次のロングメッセージを取得するためバッファを登録する
Call ADDLongMsgBuff
'受信したロングメッセージを文字列に変換する
BinToHex bytBuff, lngSize, strLongMsg
'リストボックスに受信メッセージを表示
Form1.List1.AddItem "LongMsg 受信 : " & strLongMsg
Case MM_MIM_LONGERROR
Form1.List1.AddItem "LongMsg Err"
'次のロングメッセージを取得するためバッファを登録する
Call ADDLongMsgBuff
Case Else
End Select
'標準のウインドウプロシージャに処理を渡す
WindowProc = CallWindowProc(oldProc, hWnd, uMsg, wParam, lParam)
End Function
|
|
Option Explicit
Private Sub Command1_Click()
Dim lngRC As Long
If Command1.Caption = "開始" Then
List1.Clear
If OpenMidiIn(Combo1.ListIndex, Form1.hWnd) = False Then
MsgBox "ERR"
CloseMidiIn
Else
StartMidiIn
Command1.Caption = "停止"
End If
Else
If CloseMidiIn = True Then
Command1.Caption = "開始"
Else
MsgBox "クローズエラー"
End If
End If
End Sub
Private Sub Form_Load()
Dim MidiInDevice As New Collection
Dim intCount As Integer
Call GetMidiInDevice(MidiInDevice)
For intCount = 1 To MidiInDevice.Count
Combo1.AddItem MidiInDevice(intCount)
Next
End Sub
Private Sub Form_Unload(Cancel As Integer)
CloseMidiIn
End Sub
|