MIDI输入是否可以避免Excel VBA崩溃？

Question

在下面的代码中，当输入 MIDI 消息开始变快时，即使我禁用了许多应用程序参数，Excel 也会崩溃。

当我启用每 7 毫秒发送一条消息的 MIDI 时钟时，代码几乎立即崩溃并且我正在运行 i7，所以，7 毫秒不是小菜一碟...？

好的，下面是完整的代码：

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

有什么想法吗？谢谢

Answer 1

我能够在一定程度上使它工作，但是当接收到 midi 时钟信号时，用于中断的 ESC 键会导致脚本崩溃，但即使在这种情况下，有时它也可以结束......去看看！

不过，只要我在下面的 Sub runClock() 中保持至少 1 毫秒的睡眠时间，一切都会正常工作。

Option Explicit

Private Const CALLBACK_FUNCTION = &H30000

'MIDI Functions here: https://docs.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

关于如何解决 ESC 键问题的任何想法？