Is it possible to Avoid Excel VBA Crashing with MIDI Input?

Question

in the following code when the input MIDI messages start to become fast the Excel Crashes even thought I disabled many application parameters.

When I enable MIDI Clock that sends a message each 7 milliseconds the code crashes almost immediately and I'm running an i7, so, 7 milliseconds wasn't suppose to be a piece of cake...?

Ok, here is the full code:

Option Explicit

Private Const CALLBACK_FUNCTION = &H30000

'For Track data
Private Const INT_TIME_SYNC             As Integer = 1

'Declaration of MIDIINCAPS Type
Private Type MIDIINCAPS
    wMid As Long                ' Manufacturer ID
    wPid As Long                ' Product ID
    vDriverVersion As Integer   ' Driver version
    szPname As String * 32      ' Product Name
    dwSupport As Double         ' Supported extra controllers (volume, etc)
End Type

Private deviceInCaps As MIDIINCAPS

'MIDI Functions here: https://learn.microsoft.com/en-us/windows/win32/multimedia/midi-functions
#If Win64 Then
    'For MIDI device INPUT
    Private Declare PtrSafe Function midiInClose Lib "winmm.dll" (ByVal hMidiIn As LongPtr) As Long
    Private Declare PtrSafe Function midiInOpen Lib "winmm.dll" (lphMidiIn As LongPtr, ByVal uDeviceID As LongPtr, ByVal dwCallback As LongPtr, ByVal dwInstance As LongPtr, ByVal dwFlags As LongPtr) As Long
    Private Declare PtrSafe Function midiInMessage Lib "winmm.dll" (ByVal hMidiIn As LongPtr, ByVal dwMsg As LongPtr) As Long
    Private Declare PtrSafe Function midiInGetNumDevs Lib "winmm.dll" () As Long
    Private Declare PtrSafe Function midiInGetDevCaps Lib "winmm.dll" Alias "midiInGetDevCapsA" (ByVal uDeviceID As LongPtr, ByRef lpCaps As MIDIINCAPS, ByVal uSize As LongPtr) As Long

    Private Declare PtrSafe Function midiInStart Lib "winmm.dll" (ByVal hMidiIn As LongPtr) As Long
    Private Declare PtrSafe Function midiInStop Lib "winmm.dll" (ByVal hMidiIn As LongPtr) As Long
    Private Declare PtrSafe Function midiInReset Lib "winmm.dll" (ByVal hMidiIn As LongPtr) As Long
#Else
    'For MIDI device INPUT
    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 midiInMessage Lib "winmm.dll" (ByVal hMidiIn As Long, ByVal dwMsg As Long) As Long
    Private Declare Function midiInGetNumDevs Lib "winmm.dll" () As Long
    Private Declare Function midiInGetDevCaps Lib "winmm.dll" Alias "midiInGetDevCapsA" (ByVal uDeviceID As Long, ByRef lpCaps As MIDIINCAPS, ByVal uSize 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 midiInReset Lib "winmm.dll" (ByVal hMidiIn As Long) As Long
#End If

#If Win64 Then
    Private mlngCurDevice      As Long
    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

Private i                      As Integer

Public Sub ListInputDevices()
    Dim devicesList     As String

    Debug.Print "------------------------------------------------------" & vbCrLf
    Debug.Print "Total device number: " & midiInGetNumDevs()

    For i = 1 To midiInGetNumDevs()
        mlngRc = midiInGetDevCaps(i - 1, deviceInCaps, Len(deviceInCaps))
        If (mlngRc = 0) Then
            devicesList = devicesList & i & ": " & nTrim(deviceInCaps.szPname) & vbCrLf

            Debug.Print "Manufacteur ID: " & deviceInCaps.wMid
            Debug.Print "Product ID: " & deviceInCaps.wPid
            Debug.Print "Driver Version: " & deviceInCaps.vDriverVersion
            Debug.Print "Product Name: " & nTrim(deviceInCaps.szPname)
            Debug.Print "Extra Controllers: " & deviceInCaps.dwSupport & vbCrLf

        End If
    Next
    If devicesList = "" Then devicesList = "NONE"

    MsgBox devicesList, , "Available INPUT Devices"

End Sub

'FUNCTION THAT CRASHES ALL THE TIME
Public Sub StartMidiFunction()

    With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        '.DisplayStatusBar = False
        .EnableEvents = False
    End With

    Dim lngInputIndex As Long
    lngInputIndex = 8
    Call midiInOpen(mlngHmidi, lngInputIndex, AddressOf MidiIn_Event, 0, CALLBACK_FUNCTION)
    Call midiInStart(mlngHmidi)
    Application.StatusBar = "Started"
End Sub

Public Sub EndMidiRecieve()
    Call midiInReset(mlngHmidi)
    Call midiInStop(mlngHmidi)
    Call midiInClose(mlngHmidi)
    Application.StatusBar = "Finish"

    With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = True
        .DisplayStatusBar = True
        .EnableEvents = True
    End With

End Sub

Private Function MidiIn_Event(ByVal mlngHmidi As Long, ByVal Message As Long, ByVal Instance As Long, ByVal dw1 As Long, ByVal dw2 As Long) As Long

    Dim last_dw1
    If dw1 <> last_dw1 Then
        Application.StatusBar = "Message=" & Message & " | dw1=" & dw1 & " | dw2=" & dw2
        last_dw1 = dw1
    End If

End Function

Function nTrim(theString As String) As String
    Dim iPos As Long
    iPos = InStr(theString, Chr$(0))
    If iPos > 0 Then theString = Left$(theString, iPos - 1)
    nTrim = theString
End Function

Any ideas? Thanks

Can I ask why you would use VBA for such a task? It seems like VB.NET would be a much better alternative. — braX, Dec 27 '19 at 05:14
Between the two call statements, insert `DoEvents` and try again? I mean put `DoEvents` before the line `Call midiInStart(mlngHmidi)` — Siddharth Rout, Dec 27 '19 at 05:49

Rui Monteiro · Answer 1 · 2019-12-29T09:20:25.927

I was able to make it work in some extent, however when receiving midi clock signals the ESC key used to interrupted crashes the script, but even in this case sometimes it ends ok... Go figure!

Nevertheless everything works just fine as long as I maintain the Sleep of at least 1 millisecond in the Sub runClock() bellow.

Option Explicit

Private Const CALLBACK_FUNCTION = &H30000

'MIDI Functions here: https://learn.microsoft.com/en-us/windows/win32/multimedia/midi-functions
#If Win64 Then
    Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr)
    Private Declare PtrSafe Function timeGetTime Lib "winmm.dll" () As Long
    'For MIDI device INPUT
    Private Declare PtrSafe Function midiInOpen Lib "winmm.dll" (lphMidiIn As LongPtr, ByVal uDeviceID As LongPtr, ByVal dwCallback As LongPtr, ByVal dwInstance As LongPtr, ByVal dwFlags As LongPtr) As Long
    Private Declare PtrSafe Function midiInClose Lib "winmm.dll" (ByVal hMidiIn As LongPtr) As Long
    Private Declare PtrSafe Function midiInStart Lib "winmm.dll" (ByVal hMidiIn As LongPtr) As Long
    Private Declare PtrSafe Function midiInStop Lib "winmm.dll" (ByVal hMidiIn As LongPtr) As Long
    Private Declare PtrSafe Function midiInReset Lib "winmm.dll" (ByVal hMidiIn As LongPtr) As Long
#Else
    Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
    Private Declare Function timeGetTime Lib "winmm.dll" () As Long
    'For MIDI device INPUT
    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 midiInClose 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 midiInReset Lib "winmm.dll" (ByVal hMidiIn As Long) As Long
#End If

#If Win64 Then
    Private mlngCurDevice      As Long
    Private mlngHmidi          As LongPtr
#Else
    Private mlngCurDevice      As Long
    Private mlngHmidi          As Long
#End If

Private ClockTicks             As Integer
Private Notes                  As Integer
Private Looper                 As Long
Private LongMessage            As Long
Private actualTime             As Long

'Main sub function that manages the Callback Function output
Public Sub runClock()

    'When canceled become able to close opened Input devices!
    On Error GoTo handleCancel
    Application.EnableCancelKey = xlErrorHandler

    With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        '.DisplayStatusBar = False
        '.EnableEvents = False
    End With

    mlngCurDevice = 8
    Notes = 0
    Looper = 0

    'Open Input Device
    Call midiInOpen(mlngHmidi, mlngCurDevice, AddressOf MidiIn_Event, 0, CALLBACK_FUNCTION)

    'Ends only when Status is different from 0
    Do While Notes < 10
        'Reset Status count
        ClockTicks = 0

        'Begins lissinting the MIDI input
        Call midiInStart(mlngHmidi)

        'Loops until the right message is given <= 255 and > 0
        Do While ClockTicks < 1000
            'Sleep if needed
            Sleep 10 'Needs to be at least 1 millisecond
            Application.StatusBar = "Looper=" & Looper & " | Notes=" & Notes & " | ClockTicks=" & ClockTicks & " | Message=" & LongMessage
            Looper = Looper + 1
            'DoEvents enables ESC key
            If Abs(timeGetTime - actualTime) > 3000 Then
                DoEvents
                actualTime = timeGetTime
            End If
        Loop

        'Ends lisingting the MIDI input
        Do While midiInReset(mlngHmidi) <> 0
        Loop
        Do While midiInStop(mlngHmidi) <> 0
        Loop

    Loop

    'Closes Input device
    Do While midiInClose(mlngHmidi) <> 0
    Loop

    With Application
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
        .DisplayStatusBar = True
        .EnableEvents = True
    End With

    MsgBox "END", , "Available INPUT Devices"

    'Close all opened MIDI Inputs when canceled
handleCancel:
        If Err.Number = 18 Then

            'Ends lisingting the MIDI input
            Do While midiInReset(mlngHmidi) <> 0
            Loop
            Do While midiInStop(mlngHmidi) <> 0
            Loop
            Do While midiInClose(mlngHmidi) <> 0
            Loop

            With Application
                .Calculation = xlCalculationAutomatic
                .ScreenUpdating = True
                .DisplayStatusBar = True
                .EnableEvents = True
            End With

            MsgBox "END", , "Available INPUT Devices"

        End If

End Sub

Private Function MidiIn_Event(ByVal mlngHmidi As Long, ByVal Message As Long, ByVal Instance As Long, ByVal dw1 As Long, ByVal dw2 As Long) As Long

    If Message = 963 Then
        LongMessage = Message
        If dw1 > 255 Then
            Notes = Notes + 1
        Else
            ClockTicks = ClockTicks + 1
        End If
    End If

End Function

Any ideas in how to solve the ESC key issue?

Is it possible to Avoid Excel VBA Crashing with MIDI Input?

1 Answers1