How to Play MIDI Sounds with VBA

Who said Office is boring? Excel applications can be spiced-up with sound effects. MIDI sounds can be used to provide audible feedback to users limited only by your creativity!

Our Excel version of the viral 2048 game uses MIDI sounds to enhance game play. For the technical minded, here is a MIDI comprehensive resource.
2048 Game MIDI VBA Code

Option Explicit

#If Win64 Then
    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 midiOutClose Lib "winmm.dll" (ByVal hMidiOut As LongPtr) As Long
    Private Declare PtrSafe Function midiOutShortMsg Lib "winmm.dll" (ByVal hMidiOut As LongPtr, ByVal dwMsg As Long) As Long
#Else
    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
#End If

#If Win64 Then
    Private hMidiOut1 As LongLong
#Else
    Private hMidiOut1 As Long
#End If

Private m_bAudio As Boolean

Public Sub MidiOpen()
    
    MidiClose
    midiOutOpen hMidiOut1, 0, 0, 0, 0
    
End Sub

Public Sub MidiClose()

    midiOutClose hMidiOut1
    hMidiOut1 = 0
    
End Sub

Public Sub MidiSetInstrument(ByVal InstrumentID As Long)
    
    If hMidiOut1 = 0 Then MidiOpen
    midiOutShortMsg hMidiOut1, (256 * InstrumentID) + 192
    
End Sub

Public Sub MidiPlayNote(ByVal Note As Integer, ByVal Volume As Integer)
    
    If hMidiOut1 = 0 Then MidiOpen
    midiOutShortMsg hMidiOut1, RGB(144, Note, Volume)
    
End Sub

Public Sub MidiPlayNoteEx(ByVal InstrumentID As Long, ByVal Note As Integer, ByVal Volume As Integer, ByVal Wait As Integer)

    Dim dWait As Double
    
    If Not m_bAudio Then Exit Sub
    If hMidiOut1 = 0 Then MidiOpen
    MidiSetInstrument InstrumentID
    MidiPlayNote Note, Volume
    dWait = Timer + CDbl(Wait) / 16
    While Timer < dWait
        DoEvents
    Wend
    If Wait > 0 Then MidiPlayNote Note, 0
    
End Sub

Public Sub ToggleAudio()

    m_bAudio = Not ThisWorkbook.Sheets("Game").Shapes("GroupControlAudioOn").Visible
    Game.Unprotect
    ThisWorkbook.Sheets("Game").Shapes("GroupControlAudioOn").Visible = m_bAudio
    ThisWorkbook.Sheets("Game").Shapes("GroupControlAudioOff").Visible = Not m_bAudio
    Game.Protect
    
End Sub

Public Sub MidiStartGame()

    m_bAudio = ThisWorkbook.Sheets("Game").Shapes("GroupControlAudioOn").Visible
    MidiPlayNoteEx 55, 44, 127, 2
    MidiPlayNoteEx 55, 56, 127, 4
    
End Sub

Public Sub MidiMakeMove(ByVal NumPoints As Long)

    Select Case True
        Case NumPoints < 2
            ' You get NOTHING here
            MidiPlayNoteEx 13, 6, 63, 0
        Case NumPoints < 4
            MidiPlayNoteEx 116, 20, 127, 0
        Case NumPoints < 8
            MidiPlayNoteEx 116, 28, 127, 0
        Case NumPoints < 16
            MidiPlayNoteEx 116, 36, 127, 0
        Case NumPoints < 32
            MidiPlayNoteEx 116, 44, 127, 0
        Case NumPoints < 64
            MidiPlayNoteEx 116, 52, 127, 0
        Case NumPoints < 128
            MidiPlayNoteEx 116, 60, 127, 0
        Case NumPoints < 256
            MidiPlayNoteEx 55, 40, 127, 0
        Case NumPoints < 512
            MidiPlayNoteEx 55, 44, 127, 0
        Case NumPoints < 1024
            MidiPlayNoteEx 55, 48, 127, 0
        Case NumPoints < 2048
            MidiPlayNoteEx 55, 54, 127, 0
        Case Else
            MidiPlayNoteEx 55, 60, 127, 0
    End Select
    
End Sub

Public Sub MidiGameOver(ByVal IsWin As Boolean)

    If IsWin Then
        MidiPlayNoteEx 55, 52, 127, 2
        MidiPlayNoteEx 55, 48, 127, 4
        MidiPlayNoteEx 55, 56, 127, 0
    Else
        MidiPlayNoteEx 123, 64, 120, 0
    End If
    
End Sub

Public Sub MakeTestNoise()

    Dim I As Long
    
    If hMidiOut1 = 0 Then MidiOpen
    If False Then
        For I = 0 To 127
            Debug.Print "Playing Instrument #"; I
            MidiPlayNoteEx I, 40, 60, 40
            MidiPlayNoteEx I, 40, 0, 10
        Next
    Else
        MidiPlayNoteEx 122, 64, 100, 60
    End If
    ' Dummy
    ' Good Instruments: 11, 18, 55, 116 (drum), 123 (bird)
    
End Sub
How To Play MIDI Sounds With VBA

2048 Game MIDI VBA Code
