VBAでmidiを叩いてiphoneのopeningを鳴らす。
この動画のマクロはWindows11/Office2016で作成してます。
iphoneのopeningを鳴らすのはtest3です。
'MIDI API
Private Declare PtrSafe Function midiOutGetNumDevs Lib "winmm" () As Integer
Private Declare PtrSafe Function midiOutOpen Lib "winmm.dll" (lphMidiOut As LongPtr, ByVal uDeviceID As Long, ByVal dwCallback As LongPtr, ByVal dwInstance As LongPtr, ByVal dwflags As Long) As Long
Private Declare PtrSafe Function midiOutShortMsg Lib "winmm.dll" (ByVal hMidiOut As LongPtr, ByVal dwMsg As Long) As Long
Private Declare PtrSafe Function midiOutClose Lib "winmm.dll" (ByVal hMidiOut As LongPtr) As Long
Dim Handle As LongPtr
'Sleep API
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr)
Private Declare PtrSafe Function MessageBoxTimeoutA Lib "User32.dll" (ByVal hWnd As LongPtr, ByVal lpText As String, ByVal lpCaption As String, ByVal uType As VbMsgBoxStyle, ByVal wLanguageID As Long, ByVal dwMilliseconds As Long) As Long
Sub test1()
Dim Msg As Long
'MIDI出力デバイス取得
Dim Ret As Long
Ret = midiOutGetNumDevs
'MIDIデバイスを開く
If Ret = 0 Then
Debug.Print "MIDI音源が無いため利用できません。"
Exit Sub
End If
Ret = midiOutOpen(Handle, -1, 0, 0, 0)
Msg = &H12C0
Call midiOutShortMsg(Handle, Msg) ' 楽器をオルガンに変更
Msg = &H7F3C90
Call midiOutShortMsg(Handle, Msg) 'ド note on note=60 Hexで3C
Sleep (1000) '1秒待つ
Msg = &H7F3C80
Call midiOutShortMsg(Handle, Msg) 'ド note off note=60 Hexで3C
Sleep (1000) '1秒待つ
Msg = &H7F3E90
Call midiOutShortMsg(Handle, Msg) 'レ note on note=62 Hexで3E
Sleep (1000) '1秒待つ
Msg = &H7F3E80
Call midiOutShortMsg(Handle, Msg) 'レ note off note=62 Hexで3E
Sleep (1000) '1秒待つ
Msg = &H7F4090
Call midiOutShortMsg(Handle, Msg) 'ミ note on note=64 Hexで40
Sleep (1000) '1秒待つ
Msg = &H7F4080
Call midiOutShortMsg(Handle, Msg) 'ミ note off note=64 Hexで40
Sleep (1000) '1秒待つ
'MIDIデバイスを閉じる
Ret = midiOutClose(Handle)
End Sub
Sub test2()
Dim Msg As Long
'MIDI出力デバイス取得
Dim Ret As Long
Ret = midiOutGetNumDevs
'MIDIデバイスを開く
If Ret = 0 Then
Debug.Print "MIDI音源が無いため利用できません。"
Exit Sub
End If
Ret = midiOutOpen(Handle, -1, 0, 0, 0)
gakki = ""
For i = 0 To &H7F
Msg = i * 256 + &HC0
Debug.Print i
Call midiOutShortMsg(Handle, Msg) '
Msg = &H7F3C90
Call midiOutShortMsg(Handle, Msg) 'ド note=60 Hexで3C
If ExistsSheet("楽器一覧") Then
MessageBoxTimeoutA 0, i & " " & Sheets("楽器一覧").Cells(i + 1, 2).Value, "楽器", 0, 65536, 950
Else
MessageBoxTimeoutA 0, i & " の音です", "楽器", 0, 65536, 950
End If
Msg = &H78B0
Call midiOutShortMsg(Handle, Msg) 'オールサウンドオフ。発音中の音を残響も消す
Sleep (50) '1秒待つ
DoEvents
Next
'MIDIデバイスを閉じる
Ret = midiOutClose(Handle)
End Sub
Sub test3()
'iphoneのopeningを鳴らす
Dim Msg As Long
'MIDI出力デバイス取得
Dim Ret As Long
Ret = midiOutGetNumDevs
midi_dat = "48,46,43,,48,,41,,48,,46,,48,,41,,,,,,,,43,,,,43,,46,,48,,48,46,43,,48,,41,,48,,46,,48,,41,,,,,,,,43,,,,43,,46,,48,"
'MIDIデバイスを開く
If Ret = 0 Then
Debug.Print "MIDI音源が無いため利用できません。"
Exit Sub
End If
Ret = midiOutOpen(Handle, -1, 0, 0, 0)
'楽器をマリンバにする
Msg = &HDC0
Call midiOutShortMsg(Handle, Msg)
arr_dat = Split(midi_dat, ",")
For j = 0 To 2
For i = 0 To UBound(arr_dat)
If arr_dat(i) <> "" Then
Msg = Val("&H7F" & arr_dat(i) & "90")
Call midiOutShortMsg(Handle, Msg) '
End If
Sleep (100) '0.1秒待つ
DoEvents
Next
Next
'MIDIデバイスを閉じる
Ret = midiOutClose(Handle)
End Sub
Public Function ExistsSheet(ByVal bookName As String)
Dim ws As Variant
For Each ws In Sheets
If LCase(ws.Name) = LCase(bookName) Then
ExistsSheet = True ' 存在する
Exit Function
End If
Next
' 存在しない
ExistsSheet = False
End Function
0件のコメント