使用MIDI输入可以避免Excel VBA崩溃吗？

在下面的代码中，当输入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

选项显式
私有常量回调函数=&H30000
'用于跟踪数据
私有常量INT\u TIME\u SYNC为整数=1
'midincaps类型的声明
私有类型midincaps
wMid作为“制造商ID”的长度
wPid作为“长”产品ID
VDR版本为“整数”驱动程序版本
szPname作为字符串*32'产品名称
dwSupport作为双“受支持的额外控制器（卷等）
端型
专用设备映射为midincaps
'此处的MIDI功能：https://docs.microsoft.com/en-us/windows/win32/multimedia/midi-functions
#如果是Win64，那么
'用于MIDI设备输入
私有声明PtrSafe函数midiInClose Lib“winmm.dll”（ByVal hmidii作为LongPtr）为Long
私有声明PtrSafe函数midinopen Lib“winmm.dll”（lphMidiIn作为LongPtr，ByVal uDeviceID作为LongPtr，ByVal dwCallback作为LongPtr，ByVal dwstance作为LongPtr，ByVal dwFlags作为LongPtr）作为LongPtr
私有声明PtrSafe函数midinmessage Lib“winmm.dll”（ByVal hmidii作为LongPtr，ByVal dwMsg作为LongPtr）作为Long
私有声明PtrSafe函数midingetnumdevs Lib“winmm.dll”（长度为
私有声明PtrSafe函数midingETdevcaps Lib“winmm.dll”别名“midingETdevcapsa”（ByVal uDeviceID作为LongPtr，ByRef lpCaps作为midincaps，ByVal uSize作为LongPtr）作为LongPtr
私有声明PtrSafe函数midistart Lib“winmm.dll”（ByVal hmidii作为LongPtr）为Long
私有声明PtrSafe函数midinstop Lib“winmm.dll”（ByVal hmidii作为LongPtr）为Long
私有声明PtrSafe函数midinreset Lib“winmm.dll”（ByVal hmidii作为LongPtr）为Long
#否则
'用于MIDI设备输入
私有声明函数midiInClose Lib“winmm.dll”（ByVal hMidiIn作为Long）作为Long
私有声明函数MIDINOPEN Lib“winmm.dll”（lphMidiIn为Long，ByVal uDeviceID为Long，ByVal dwCallback为Long，ByVal dwstance为Long，ByVal dwFlags为Long）为Long
私有声明函数midinmessage Lib“winmm.dll”（ByVal-hMidiIn为Long，ByVal-dwMsg为Long）为Long
私有声明函数midinGetNumDevs Lib“winmm.dll”（长度为
私有声明函数midingETdevcaps Lib“winmm.dll”别名“midingETdevcapsa”（ByVal uDeviceID为Long，ByRef lpCaps为midincaps，ByVal uSize为Long）为Long
私有声明函数midistart Lib“winmm.dll”（ByVal hMidiIn As Long）尽可能长
私有声明函数midinstop Lib“winmm.dll”（ByVal hMidiIn为Long）为Long
私有声明函数midinreset Lib“winmm.dll”（ByVal-hMidiIn为Long）为Long
#如果结束
#如果是Win64，那么
专用MLNGCUR设备，只要
作为长PTR的私有mlngHmidi
作为LongPtr的专用mlngRc
专用MLNGMIDIMG作为LongPtr
#否则
专用MLNGCUR设备，只要
私人mlngHmidi长
私人mlngRc，只要
私有MLNGMIDIMG尽可能长
#如果结束
作为整数的私有i
公共子列表InputDevices（）
Dim DeviceList作为字符串
调试。打印“-------------------------------------------------------------”&vbCrLf
Debug.Print“设备总数：”&midingetnumdevs（）
对于i=1到midingetnumdevs（）
mlngRc=midingETdevcaps（i-1，设备映射，Len（设备映射））
如果（mlngRc=0），则
DeviceList=DeviceList&i&“：”&nTrim（deviceInCaps.szPname）和vbCrLf
调试。打印“制造商ID:”&deviceInCaps.wMid
调试。打印“产品ID:”&deviceInCaps.wPid
调试。打印“驱动程序版本：”&deviceInCaps.vDriverVersion
Debug.Print“产品名称：”&nTrim（deviceInCaps.szPname）
调试。打印“额外控制器：”&deviceInCaps.dwSupport&vbCrLf
如果结束
下一个
如果DeviceList=“”则DeviceList=“无”
MsgBox设备列表，“可用输入设备”
端接头
“总是崩溃的函数
公共子StartMidFunction（）
应用
.Calculation=xlCalculationManual
.ScreenUpdate=False
'.DisplayStatusBar=False
.EnableEvents=False
以
Dim INGINPUTINDEX尽可能长
lngInputIndex=8
调用MIDINOPEN（mlngHmidi、LNGINPUTTINDEX、MIDINU事件的地址、0、回调函数）
呼叫midiInStart（mlngHmidi）
Application.StatusBar=“已启动”
端接头
公共子EndMidReceive（）
呼叫midinreset（mlngHmidi）
呼叫MIDINSTOP（mlngHmidi）
呼叫MIDINCLOSE（mlngHmidi）
Application.StatusBar=“完成”
应用
.Calculation=xlCalculationManual
.ScreenUpdate=True
.DisplayStatusBar=True
.EnableEvents=True
以
端接头
私有函数midin_事件（ByVal mlngHmidi为Long，ByVal消息为Long，ByVal实例为Long，ByVal dw1为Long，ByVal dw2为Long）为Long
昏暗的最后一个_dw1
如果dw1最后\u dw1，则
Application.StatusBar=“Message=”&Message&“| dw1=”&dw1&“| dw2=”&dw2
last_dw1=dw1
如果结束
端函数
函数nTrim（字符串为字符串）为字符串
随着时间的推移，ipo变得黯淡
首次公开募股=仪表（字符串，Chr$（0））
如果iPos>0，则字符串=左$（字符串，iPos-1）
nTrim=字符串
端函数

---

有什么想法吗？感谢

我能够在某种程度上使它工作，但是当接收到midi时钟信号时，用于中断脚本的ESC键会崩溃，但即使在这种情况下，有时它也会正常结束。。。算了吧

尽管如此，只要我在子运行时钟（）中保持至少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