(Solved) – Is it possible to Avoid Excel VBA Crashing with MIDI Input?

  • by
(solved)-–-is-it-possible-to-avoid-excel-vba-crashing-with-midi-input?

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://docs.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

Leave a Reply

Your email address will not be published. Required fields are marked *