In this post, I can going to demonstrate how you can use VBA to interact with the MIDI capabilities of your PC to play a simple musical scale. In music, scales consist of a series of notes, that are either a semitone or wholetone (in pitch) apart from each other. In this example, we are going to play a C major diatonic scale. This will consist of 8 notes starting with C and finishing with the same note an octave higher.
C D E F G A B C
For a major scale, the interval between the 3rd and 4th notes (E & F) and the 7th and 8th notes (B & C) is a semitone. For the rest of the notes, the interval is going to be a wholetone. This will be an important thing to note, when it comes to coding the scale.
For the solution, I have created two classes called csNote and csMidi:
The class csNote, is going to be used to model each musical note within the scale. Note objects derived from this class, will have all the attributes required for the note to be played by the csMidi class. The Note class will also allow us to specify instructions in musical language, so that they can be translated into MIDI language for the csMidi class to understand. The csMidi class will encapsulate all the lower level code required for playing MIDI sounds on our PC. The code below shows how the two classes are used to play the scale:
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 |
Option Explicit Public Sub PlayMajorScale() Dim oPiano As New csMidi Dim oNote As New csNote Dim intCount As Integer oNote.NoteName = "C" oNote.OctaveNo = oNote.MiddleOctave For intCount = 1 To 8 DoEvents oPiano.PlayNote oNote Select Case intCount Case 3, 7 oNote.MoveSemiTone oNote.Up Case Else oNote.MoveWholeTone oNote.Up End Select Next Set oNote = Nothing Set oPiano = Nothing End Sub |
A Key of C is defined as well as a starting octave (this is the pitch range for the note) for the scale. The code makes 8 note iterations for the scale. With each iteration it moves the note either a wholetone or semitone up from the previous note until it reaches the last note. That is all that is required to play the scale! The code for both of the classes is presented below:
Note Class (csNote)
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 |
Option Explicit Option Base 1 Private Const INT_ACOUSTIC_GRAND As Integer = 0 Private Const INT_DEFAULT_NOTE_LENGTH As Integer = 500 Private Const INT_MAX As Integer = 127 Private Const INT_MIN As Integer = 0 Private Const INT_DEFAULT_OCTAVE_RANGE As Integer = 5 Private Const INT_MIDDLE_OCTAVE_RANGE As Integer = 5 Private Const STR_DEFAULT_NOTE_NAME As String = "C" Private mintInstrument As Integer Private mintVolume As Integer Private mintLength As Integer Private mintNote As Integer Private mintOctaveNo As Integer Private mstrNoteName As String Private Enum ENU_DIRECTION Higher = 1 Lower = 2 End Enum Private Sub Class_Initialize() mintInstrument = INT_ACOUSTIC_GRAND mintVolume = INT_MAX mintLength = INT_DEFAULT_NOTE_LENGTH mstrNoteName = STR_DEFAULT_NOTE_NAME mintOctaveNo = INT_DEFAULT_OCTAVE_RANGE mintNote = GetNoteNumber() End Sub Public Property Get Up() As Integer Up = ENU_DIRECTION.Higher End Property Public Property Get Down() As Integer Down = ENU_DIRECTION.Lower End Property Public Property Get Instrument() Instrument = mintInstrument End Property Public Property Let Volume(ByVal Value) If (Value > INT_MIN) And (Value < INT_MAX) Then mintVolume = Value End If End Property Public Property Get Volume() Volume = mintVolume End Property Public Property Let NoteLength(ByVal Value) mintLength = Value End Property Public Property Get NoteLength() NoteLength = mintLength End Property Public Property Let NoteName(ByVal Value) mstrNoteName = Value mintNote = GetNoteNumber() End Property Public Property Get NoteName() NoteName = mstrNoteName End Property Public Property Get NoteNumber() NoteNumber = mintNote End Property Public Property Get MiddleOctave() MiddleOctave = INT_MIDDLE_OCTAVE_RANGE End Property Public Property Let OctaveNo(ByVal Value) mintOctaveNo = Value End Property Public Sub MoveSemiTone(ByVal intDirection As Integer, Optional ByVal iNum As Integer = 1) MoveNote ((1 * iNum) * IIf(intDirection = ENU_DIRECTION.Lower, -1, 1)) End Sub Public Sub MoveWholeTone(ByVal intDirection As Integer, Optional ByVal iNum As Integer = 1) MoveNote ((2 * iNum) * IIf(intDirection = ENU_DIRECTION.Lower, -1, 1)) End Sub Private Sub MoveNote(ByVal intMargin As Integer) mintNote = mintNote + intMargin End Sub Private Function GetNoteNumber() Dim iBase As Integer Dim arrBaseNoteC As Variant arrBaseNoteC = Array(12, 24, 36, 48, 60, 72, 84, 96, 108) iBase = arrBaseNoteC(mintOctaveNo) Select Case mstrNoteName Case "C" iBase = iBase + 0 Case "D" iBase = iBase + 2 Case "E" iBase = iBase + 4 Case "F" iBase = iBase + 5 Case "G" iBase = iBase + 7 Case "A" iBase = iBase + 9 Case "B" iBase = iBase + 11 End Select GetNoteNumber = iBase End Function |
Midi Class (csMidi)
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 |
Option Explicit Private Const MAXPNAMELEN As Integer = 32 Private Const MMSYSERR_BASE As Integer = 0 Private Const MMSYSERR_BADDEVICEID As Integer = (MMSYSERR_BASE + 2) Private Const MMSYSERR_INVALPARAM As Integer = (MMSYSERR_BASE + 11) Private Const MMSYSERR_NODRIVER As Integer = (MMSYSERR_BASE + 6) Private Const MMSYSERR_NOMEM As Integer = (MMSYSERR_BASE + 7) Private Const MMSYSERR_INVALHANDLE As Integer = (MMSYSERR_BASE + 5) Private Const MIDIERR_BASE As Integer = 64 Private Const MIDIERR_STILLPLAYING As Integer = (MIDIERR_BASE + 1) Private Const MIDIERR_NOTREADY As Integer = (MIDIERR_BASE + 3) Private Const MIDIERR_BADOPENMODE As Integer = (MIDIERR_BASE + 6) Private Type MIDIOUTCAPS wMid As Integer wPid As Integer wTechnology As Integer wVoices As Integer wNotes As Integer wChannelMask As Integer vDriverVersion As Long dwSupport As Long szPname As String * MAXPNAMELEN End Type Private Declare Function midiOutGetNumDevs Lib "winmm" () As Integer 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 midiOutClose Lib "winmm.dll" (ByVal hMidiOut As Long) As Long 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 midiOutShortMsg Lib "winmm.dll" (ByVal hMidiOut As Long, ByVal dwMsg As Long) As Long Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) Private mlngNumDevices As Long Private mlngCurDevice As Long Private mlngHmidi As Long Private mlngRc As Long Private mlngMidiMsg As Long Private mlngMiPrivatesg As Long Private mintChannel As Integer Private mintVolume As Integer Private mintNoteLength As Integer Private mintMidiNote As Integer Private mintInstrument As Integer Private mstrDeviceName As String Private mblnIsDeviceOpen As Boolean Private Const INT_DEFAULT_CHANNEL As Integer = 0 Private Const INT_DEFAULT_VOLUME As Integer = 127 Private Const INT_DEFAULT_NOTE_LENGTH As Integer = 1000 Private Const INT_DEFAULT_CUR_DEVICE As Integer = 0 Private Sub Class_Initialize() mintChannel = INT_DEFAULT_CHANNEL mlngCurDevice = INT_DEFAULT_CUR_DEVICE mintVolume = INT_DEFAULT_VOLUME mintNoteLength = INT_DEFAULT_NOTE_LENGTH mblnIsDeviceOpen = False Call OpenDevice End Sub Private Sub Class_Terminate() Call CloseDevice End Sub Private Sub OpenDevice() On Error GoTo ERR_HANDLER: If Not mblnIsDeviceOpen Then mlngRc = midiOutClose(mlngHmidi) mlngRc = midiOutOpen(mlngHmidi, mlngCurDevice, 0, 0, 0) If (mlngRc <> 0) Then MsgBox "Couldn't open midi out, lngc = " & mlngRc mblnIsDeviceOpen = False End If mblnIsDeviceOpen = True End If Exit Sub ERR_HANDLER: Debug.Print "Open DLL Error:=" & Err.LastDllError mblnIsDeviceOpen = False End Sub Private Sub CloseDevice() If mblnIsDeviceOpen Then mlngRc = midiOutClose(mlngHmidi) mblnIsDeviceOpen = False End If End Sub Private Sub StartNote() mlngMidiMsg = &H90 + (mintMidiNote * &H100) + (mintVolume * &H10000) + mintChannel midiOutShortMsg mlngHmidi, mlngMidiMsg End Sub Private Sub StopNote() mlngMidiMsg = &H80 + (mintMidiNote * &H100) + mintChannel midiOutShortMsg mlngHmidi, mlngMidiMsg End Sub Private Sub PauseNote() Sleep mintNoteLength End Sub Public Sub PlayNote(ByVal note As csNote) mintNoteLength = note.NoteLength mintVolume = note.Volume mintInstrument = note.Instrument mintMidiNote = note.NoteNumber Call StartNote Call PauseNote End Sub Private Sub UpdateInstrument() If mblnIsDeviceOpen = True Then mlngMidiMsg = (mintInstrument * 256) + &HC0 + mintChannel + (0 * 256) * 256 midiOutShortMsg mlngHmidi, mlngMidiMsg End If End Sub Private Sub getNumberOfDevices() mlngNumDevices = (midiOutGetNumDevs() - 1) End Sub Private Sub CurrentDeviceName() Dim caps As MIDIOUTCAPS midiOutGetDevCaps mlngCurDevice, caps, Len(caps) mstrDeviceName = caps.szPname End Sub Public Function GetMIDIDevices() As String() Dim strRet() As String Dim lngLoop As Long Dim udtCap As MIDIOUTCAPS mlngNumDevices = (midiOutGetNumDevs() - 1) ReDim strRet(0) As String strRet(0) = " MIDI Mapper" For lngLoop = 0 To mlngNumDevices mlngRc = midiOutGetDevCaps(lngLoop, udtCap, Len(udtCap)) ReDim Preserve strRet(lngLoop + 1) As String strRet(lngLoop + 1) = udtCap.szPname Next GetMIDIDevices = strRet() End Function |
Thank you for reading this post. Please take time to read the disclaimer about content found on this site.
Share :
Hi,
I believe you missed to call StopNote at line 111 of PlayNote in Midi Class (csMidi) in order to release ON keys!
Regards
Well spotted ! Thanks, yes that the note should logically be stopped after starting.
Very useful code, however for the 64bit office version you need to do the following!
#If Win64 Then
Private Declare PtrSafe Function midiOutClose Lib “winmm.dll” (ByVal hMidiOut As LongPtr) As Long
Private Declare PtrSafe Function midiOutOpen Lib “winmm.dll” (lphMidiOut As LongPtr, ByVal uDeviceID As LongPtr, ByVal dwCallback As LongPtr, ByVal dwInstance As LongPtr, ByVal dwflags As LongPtr) As Long
Private Declare PtrSafe Function midiOutShortMsg Lib “winmm.dll” (ByVal hMidiOut As LongPtr, ByVal dwMsg As LongPtr) As Long
Private Declare PtrSafe Function timeGetTime Lib “winmm.dll” () As Long
#Else
Private Declare Function midiOutClose Lib “winmm.dll” (ByVal hMidiOut As Long) As Long
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 midiOutShortMsg Lib “winmm.dll” (ByVal hMidiOut As Long, ByVal dwMsg As Long) As Long
Private Declare Function timeGetTime Lib “winmm.dll” () As Long
#End If
#If Win64 Then
Private mlngCurDevice As LongPtr
Private mlngHmidi As LongPtr
Private mlngRc As LongPtr
Private mlngMidiMsg As LongPtr
#Else
Private mlngCurDevice As Long
Private mlngHmidi As Long
Private mlngRc As Long
Private mlngMidiMsg As Long
#End If
Thanks for the code.
I keep getting ‘Couldn’t open midi out lngc=4’
Any ideas?
Bensley
Hi Bensley, this is a message produced by the code when it has an issue trying to open the midi port on your computer. It is on line 72 of the the csMidi class. When the function “midiOutOpen” is called if the return value is anything other than a 0, this indicates that the class was unable to open the port. Put a debug statement on line 70 and see what the return value of “mlngRc” is. Then check this value against the error messages listed on the api documentation here:
https://docs.microsoft.com/en-us/previous-versions/dd798476(v=vs.85)
Go to the section “RETURN VALUE”. This will hopefully tell you what the issue is.
Hello
I’ve the same problem but this list is alphanumeric and the error is numeric (lngc=4).
However, what can I do with this error (4)?