カテゴリー
VBA

VBAでiphoneのopeningを鳴らす

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

コメントを残す

メールアドレスが公開されることはありません。 が付いている欄は必須項目です

このサイトはスパムを低減するために Akismet を使っています。コメントデータの処理方法の詳細はこちらをご覧ください