Focus to MgsBox when Excel is not active - excel

I have checked related questions such as this or this one but the solutions there do not seem to solve my problem.
I am running a VBA script on my computer. The script takes a few minutes to execute and while waiting I am checking other things in my computer. To get my attention once the script has finished running, I have included a MsgBox at the end of my script. However, because Excel is not active/selected when the script finishes, I cannot see it - only when I reactivate/select Excel.
How can I bring into focus the MsgBox when Excel is not active? I have already tried the following tweaks but they do not work:
ThisWorkbook.Activate:
...
ThisWorkbook.Activate
MsgBox "..."
...
AppActivate() (this command threw an error):
...
AppActivate("Microsoft excel")
MsgBox "..."
...

How about playing a sound when the program finishes?
Place this declaration at the top of a standard code module, above any procedures existing there.
Public Declare Function Beep Lib "kernel32" _
(ByVal dwFreq As Long, _
ByVal dwDuration As Long) As Long
If you place this procedure in the same module you may not need it to be public. Adjust pitch and duration to your preference.
Sub EndSound()
Beep 500, 1000
End Sub
Then place the procedure call at the end of your program.
Call EndSound
I suppose you might use a more elaborate sound - may I suggest a couple of bars from Beethoven's 5th? Modify the EndSound procedure. Chip Pearson has more on this idea.

Try:
Application.WindowState = xlMaximized

Disclaimer: This is not my code and I do not know who the author is. I had this code in my database.
Put your code in Sub Sample(). I have shown where you can insert your code. Once the code is run, Excel will flash 5 times. you can change this number by changing Private Const NumberOfFlashes = 5
Paste this in a Module.
Option Explicit
Private Type FLASHWINFO
cbSize As Long
Hwnd As Long
dwFlags As Long
uCount As Long
dwTimeout As Long
End Type
Private Const FLASHW_STOP As Long = 0
Private Const FLASHW_CAPTION As Long = &H1
Private Const FLASHW_TRAY As Long = &H2
Private Const FLASHW_ALL As Long = (FLASHW_CAPTION Or FLASHW_TRAY)
Private Const FLASHW_TIMER As Long = &H4
Private Const FLASHW_TIMERNOFG As Long = &HC
Private FLASHW_FLAGS As Long
Private Declare Function LoadLibrary Lib "kernel32" _
Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
Private Declare Function GetProcAddress Lib "kernel32" _
(ByVal hModule As Long, ByVal lpProcName As String) As Long
Private Declare Function FreeLibrary Lib "kernel32" _
(ByVal hLibModule As Long) As Long
Private Declare Function FlashWindowEx Lib "user32" _
(FWInfo As FLASHWINFO) As Boolean
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Const NumberOfFlashes = 5
Private Function APIFunctionPresent(ByVal FunctionName _
As String, ByVal DllName As String) As Boolean
Dim lHandle As Long
Dim lAddr As Long
lHandle = LoadLibrary(DllName)
If lHandle <> 0 Then
lAddr = GetProcAddress(lHandle, FunctionName)
FreeLibrary lHandle
End If
APIFunctionPresent = (lAddr <> 0)
End Function
Sub Sample()
'
' Put your code here. Once that code finishes, Excel will FLASH
'
Dim udtFWInfo As FLASHWINFO
If Not APIFunctionPresent("FlashWindowEx", "user32") Then Exit Sub
With udtFWInfo
.cbSize = Len(udtFWInfo)
.Hwnd = Application.Hwnd
.dwFlags = FLASHW_FLAGS Or FLASHW_TRAY
.uCount = NumberOfFlashes
.dwTimeout = 0
End With
Call FlashWindowEx(udtFWInfo)
MsgBox "Done"
End Sub

The easiest way is to probably to create a userform instead then set the focus to this when it initialises.
Code in the userform to show as modal:
Private Declare Function FindWindow Lib "User32" Alias "FindWindowA" (ByVal lpClassName _
As String, ByVal lpWindowName As String) As Long
Private Declare Function SetWindowPos Lib "User32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, _
ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Const SWP_NOSIZE = &H1
Private Const SWP_NOMOVE = &H2
Private Const FLAGS As Long = SWP_NOMOVE Or SWP_NOSIZE
Private Const HWND_TOPMOST = -1
Private Sub UserForm_Initialize()
Dim hwnd As Long: hwnd = FindWindow(vbNullString, Me.Caption)
If hwnd > 0 Then SetWindowPos hwnd, HWND_TOPMOST, 0, 0, 0, 0, FLAGS ' Set Modal
End Sub

Related

How to detect mouse release for a shape, not a button in Excel

I want to make a button that plays a sound, but stops playing when I release the click. I tried using command buttons, but it stops the whole program, until the sound ends. So, I used a normal rectangle instead. There is MouseUp event for the command buttons, but I need something for shapes.
I have this code:
#If VBA7 Then
Public Declare PtrSafe Function WINMM Lib "winmm.dll" _
Alias "PlaySoundA" (ByVal lpszName As String, _
ByVal hModule As Long, ByVal dwFlags As Long) As Long
#Else
Public Declare Function WINMM Lib "winmm.dll" _
Alias "PlaySoundA" (ByVal lpszName As String, _
ByVal hModule As Long, ByVal dwFlags As Long) As Long
#End If
Const SND_SYNC = &H0
Const SND_ASYNC = &H1
Const SND_FILENAME = &H20000
Private Sub Obdélník1_Click()
Path = ThisWorkbook.Path & "\Sound1.wav"
Call WINMM(Path, 0&, SND_ASYNC Or SND_FILENAME)
End Sub
Private Sub Obdélník1_Release()
Path = ThisWorkbook.Path & "\Sound2.wav" 'Sound2 is just a short silent sound, that replaces the Sound1
Call WINMM(Path, 0&, SND_ASYNC Or SND_FILENAME)
End Sub
How to activate the last macro on the click release?

CTD in Excel VBA

My macro is causing excel to crash to desktop with no debug or error message, the whole application shuts down, closing any open instances of excel.
The code that I've written so far is pretty light, so I have no idea what is causing the crash.
The crash appears to occur after StartGame() has finished. I assume it's being caused by the Timer which runs Main() every 50ms as the CTD exclusively happens after End Sub in StartGame().
I've included all the code below.
Main Module
Option Explicit
Public Sub StartGame()
InitialiseGame
InitialiseTimer
GameRunning = True
End Sub
Public Sub Main()
If GameInput.TabIsPressed Then TerminateTimer
If Not GameRunning Then Exit Sub
Graphics.DrawSquare
End Sub
Private Sub InitialiseGame()
Set GameInput = New ClassGameInput
Set Graphics = New ClassGraphics
Set Square = New ClassSquare
End Sub
Timer Module
Option Explicit
Private Const MILLISECONDS_IN_SECOND As Integer = 1000
Private Const GAME_TICKS_PER_SECOND As Integer = 20
Private GameTimerID As Long
Public Sub InitialiseTimer()
Dim GameTimerInterval As Double
GameTimerInterval = MILLISECONDS_IN_SECOND / GAME_TICKS_PER_SECOND
Sleep (500)
GameTimerID = SetTimer(0, 0, GameTimerInterval, AddressOf Main)
End Sub
Public Sub TerminateTimer()
If GameTimerID <> 0 Then
KillTimer 0, GameTimerID
GameTimerID = 0
GameRunning = False
End If
Set GameInput = Nothing
Set Graphics = Nothing
Set Square = Nothing
End Sub
Public Declarations Module
Option Explicit
#If Win64 Then
Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
Public Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
Public Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
#Else
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Public Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
Public Declare PtrSafe Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
#End If
Public Const BORDER_START_X As Integer = 4
Public Const BORDER_START_Y As Integer = 4
Public Const BORDER_END_X As Integer = 185
Public Const BORDER_END_Y As Integer = 73
Public Const SQUARE_SIZE As Integer = 10
Public Const SQUARE_COLOUR As Long = rgbLightBlue
Public GameRunning As Boolean
Public GameInput As ClassGameInput
Public Graphics As ClassGraphics
Public Square As ClassSquare
Class GameInput
Option Explicit
Public Function UpIsPressed() As Boolean
UpIsPressed = (GetAsyncKeyState(vbKeyUp) <> 0)
End Function
Public Function DownIsPressed() As Boolean
DownIsPressed = (GetAsyncKeyState(vbKeyDown) <> 0)
End Function
Public Function LeftIsPressed() As Boolean
LeftIsPressed = (GetAsyncKeyState(vbKeyLeft) <> 0)
End Function
Public Function RightIsPressed() As Boolean
RightIsPressed = (GetAsyncKeyState(vbKeyRight) <> 0)
End Function
Public Function TabIsPressed() As Boolean
TabIsPressed = (GetAsyncKeyState(vbKeyTab) <> 0)
End Function
Class Graphics
Option Explicit
Const COL_WIDTH As Double = 0.83
Const ROW_HEIGHT As Double = 7.5
Private GameCanvas As Range
Private Sub Class_Initialize()
With shtGame
.cmdGo.Visible = False
.Cells.Columns.ColumnWidth = COL_WIDTH
.Cells.Rows.RowHeight = ROW_HEIGHT
.EnableSelection = xlNoSelection
.Protect AllowFormattingCells:=True
.Cells.Interior.Color = rgbDarkSlateGrey
Set GameCanvas = .Range(.Cells(BORDER_START_Y, BORDER_START_X), .Cells(BORDER_END_Y, BORDER_END_X))
GameCanvas.Interior.Pattern = xlNone
End With
End Sub
Public Sub DrawSquare(SquareX As Integer, SquareY As Integer)
Dim SquareRange As Range
With shtGame
Set SquareRange = .Range(.Cells(SquareY, SquareX), .Cells(SquareY + SQUARE_SIZE - 1, SquareX + SQUARE_SIZE - 1))
SquareRange.Interior.Color = SQUARE_COLOUR
End With
End Sub
Private Sub Class_Terminate()
With shtGame
.cmdGo.Visible = True
.EnableSelection = xlNoRestrictions
.Unprotect
.Cells.Clear
End With
End Sub
Class Square
Option Explicit
Private SquareX As Integer
Private SquareY As Integer
Private Sub Class_Initialize()
SquareX = BORDER_START_X
SquareY = BORDER_START_Y
End Sub
Sorry for the big fat code dump, but I really have no idea what is causing the problem!
Any help is greatly appreciated!
The CTD was being caused by missing arguments when calling DrawSquare().
I had incorrectly missed the x and y co-ordinates of the sub.
Normally, the compiler would pick-up on this error, however as the Main module was being called automatically by my timer no error checking was taking place.
Public Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long

Set TabStops on a ListBox control in VBA Excel

I first came onto that post here by Randy Birch about listing clipboard formats. As you can see, he is using Visual Basic 6 and also a .Refresh method on List1 after sending the LB_SETTABSTOPS messages to the WNDPROC handling the window corresponding to his "List1" ListBox
Since the .Refresh method is not available in VBA (and also the .Hwnd, but that is less a problem withing this post by C. PEARSON and Private Declare Function GetFocus Lib "user32" () As Long), I tried to 'mimic' it.
Apparently, the .Refresh method invalidates the whole client area of the ListBox Window, and then sends a WM_PAINT message to the WNDPROC bypassing any other pending messages in message queue, causing an immediate repaint of the update region, which should be the entire visible "List1" ListBox in this particular case.
My config :
Debug.Print Application.Version
Debug.Print Application.VBE.Version
Debug.Print Application.OperatingSystem
#If VBA6 Then
Debug.Print "VBA6 = True"
#Else
Debug.Print "VBA6 = False"
#End If
#If VBA7 Then
Debug.Print "VBA7 = True"
#Else
Debug.Print "VBA7 = False"
#End If
Results in:
16.0
7.01
Windows (32-bit) NT 10.00
VBA6 = True
VBA7 = True
Now my attempt #1 :
Option Explicit
Private Const LB_SETTABSTOPS As Long = &H192
Private Const EM_SETTABSTOPS As Long = &HCB
Private Const RDW_ALLCHILDREN = &H80
Private Const RDW_ERASE = &H4
Private Const RDW_ERASENOW = &H200
Private Const RDW_FRAME = &H400
Private Const RDW_INTERNALPAINT = &H2
Private Const RDW_INVALIDATE = &H1
Private Const RDW_NOCHILDREN = &H40
Private Const RDW_NOERASE = &H20
Private Const RDW_NOFRAME = &H800
Private Const RDW_NOINTERNALPAINT = &H10
Private Const RDW_UPDATENOW = &H100
Private Const RDW_VALIDATE = &H8
Private hWndList1 As Long
Private Type Rect
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hWnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Declare Function GetFocus Lib "user32" () As Long
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Private Declare PtrSafe Function UpdateWindow Lib "user32" (ByVal hWnd As LongPtr) As Boolean
Private Declare Function VarPtrArray Lib "msvbvm60.dll" Alias "VarPtr" (ByRef lpRect As Rect) As Long
Private Declare Function RedrawWindow Lib "user32" (ByVal hWnd As Long, ByRef lprcUpdate As Rect, ByVal hrgnUpdate As Long, Optional ByVal flags As Integer) As Boolean
Private Declare Function InvalidateRect Lib "user32" (ByVal hWnd As Long, ByRef lpRect As Rect, ByVal bErase As Boolean) As Long
Private Declare Function GetUpdateRect Lib "user32" (ByVal hWnd As Long, ByRef lpRect As Rect, ByVal bErase As Boolean) As Boolean
Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, ByRef lpRect As Rect) As Boolean
Private Declare Function CreateRectRgnIndirect Lib "gdi32" (ByRef lpRect As Rect) As Long
Private Declare Function GetClientRect Lib "user32" (ByVal hWnd As Long, ByRef lpRect As Rect) As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Sub UserForm_Initialize()
Dim ListWindowUpdated As Boolean
Dim ListWindowRedrawn As Boolean
ReDim TabStop(0 To 1) As Long
TabStop(0) = 90
TabStop(1) = 130
With List1
.Clear
.SetFocus
hWndList1 = GetFocus
Call SendMessage(hWndList1, LB_SETTABSTOPS, 0&, ByVal 0&)
Call SendMessage(hWndList1, LB_SETTABSTOPS, 2, TabStop(0))
Dim rectList1 As Rect
Call GetWindowRect(hWndList1, rectList1)
Dim lprcList1 As Long
lprcList1 = VarPtrArray(rectList1)
ListWindowRedrawn = RedrawWindow(hWndList1, rectList1, lprcList1, RDW_INVALIDATE)
ListWindowRedrawn = RedrawWindow(hWndList1, rectList1, 0, RDW_INVALIDATE)
MsgBox "ListWindowRedrawn = " & ListWindowRedrawn & " and RDW_INVALIDATE message sent"
'Call RedrawWindowAny(hWndForm2, vbNull, 1&, RDW_INVALIDATE Or RDW_UPDATENOW Or RDW_ALLCHILDREN)
ListWindowUpdated = UpdateWindow(hWndList1)
MsgBox "ListWindowUpdated = " & ListWindowUpdated
End With
End Sub
My attempt #2 :
Dim ScreenRect As Rect
Dim hClientRect As Long
hClientRect = GetClientRect(hWndList1), ScreenRect)
Dim udtScrDim As Rect
Dim lReturn As Long
Dim hRegion As Long
udtScrDim.Left = 0
udtScrDim.Top = 0
udtScrDim.Right = ScreenRect.Right - ScreenRect.Left
MsgBox "Screen width = " & ScreenRect.Right - ScreenRect.Left
udtScrDim.Bottom = ScreenRect.Bottom - ScreenRect.Top
MsgBox "Screen height = " & ScreenRect.Bottom - ScreenRect.Top
hRegion = CreateRectRgnIndirect(udtScrDim)
If hRegion <> 0 Then
lReturn = RedrawWindow(0, udtScrDim, hRegion, RDW_ERASE Or RDW_FRAME Or RDW_INVALIDATE Or RDW_UPDATENOW Or RDW_INTERNALPAINT Or RDW_ALLCHILDREN)
End If
After many attemps, I still can't get the client area to be updated with the custom tabstop positions. But the attempt #1 above still seems to be the more logical to me. It works fine, no errors, but nothing changes, any item (containing vbTab) in the ListBox won't be affected, even with a later UserForm1.Repaint.
Please help :)
This is not quite an answer but more a workaround :
My understanding of the problem (and of Randy Birch) :
The only explaination is that the VBA Listbox control simply can't deal with LB_SETTABSTOPS messages. Indeed I also tried sending the LB_SETTABSTOPS message later, but it's still ignored. Same thing with the invalidate message and WM_PAINT.
That might be why the Office devs implemented the .ColumnWidth property in VBA Excel which can do exactly the same things that what I was trying to do above.

Minimize UserForm when macro in it is running

I am trying to minimize a Userform when it is running a method in it. Functionality in my method is so huge that it is running for long time. I would like to minimize UserForm so that I could work on some other excel sheets and later come back to UserForm (or restore it) during this run.
When UserForm is running, it is not allowing to access any of its components(so that even if i add minimize button its of no use). I am able to access other excels and work on them because i have made Userform as vbmodeless, but my requirement is userform should be minimized, now I am dragging UserForm to the end of the screen to view other files easily.
Why not add a minimize / maximize to your userform ;)
Here is something from my database (Not my Code). Paste this in the userform
Option Explicit
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
(ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function DrawMenuBar Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function ShowWindow Lib "user32" _
(ByVal hWnd As Long, ByVal nCmdShow As Long) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _
(ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Const WS_MINIMIZEBOX As Long = &H20000
Private Const WS_MAXIMIZEBOX As Long = &H10000
Private Const GWL_STYLE As Long = (-16)
Private Const WS_SYSMENU As Long = &H80000
Private Const SW_SHOWMAXIMIZED = 3
Private Sub UserForm_Activate()
Dim Ret As Long, styl As Long
Ret = FindWindow("ThunderDFrame", Me.Caption)
styl = GetWindowLong(Ret, GWL_STYLE)
styl = styl Or WS_SYSMENU
styl = styl Or WS_MINIMIZEBOX
styl = styl Or WS_MAXIMIZEBOX
SetWindowLong Ret, GWL_STYLE, (styl)
DrawMenuBar Ret
End Sub
Screenshot

Controlling Excel via Midi controller

I've got one of these
(source: netdna-cdn.com)
and wanted to use the sliders on it to control Excel, just like one of the Excel form control scroll bars.
I've managed to modify this code for VBA, but it is extremely unstable.
Can anyone help me stabilize it? I think the function MidiIn_Event may crash if it doesn't return fast enough, but I may be wrong.
Thanks in advance.
Public Const CALLBACK_FUNCTION = &H30000
Public Declare Function midiInOpen Lib "winmm.dll"
(lphMidiIn As Long,
ByVal uDeviceID As Long, ByVal dwCallback As Any,
ByVal dwInstance As Long, ByVal dwFlags As Long) As Long
Public Declare Function midiInClose Lib "winmm.dll"
(ByVal hMidiIn As Long) As Long
Public Declare Function midiInStart Lib "winmm.dll"
(ByVal hMidiIn As Long) As Long
Public Declare Function midiInStop Lib "winmm.dll"
(ByVal hMidiIn As Long) As Long
Public Declare Function midiInReset Lib "winmm.dll"
(ByVal hMidiIn As Long) As Long
Private ri As Long
Public Sub StartMidiFunction()
Dim lngInputIndex As Long
lngInputIndex=0
Call midiInOpen(ri, lngInputIndex, AddressOf MidiIn_Event,
0, CALLBACK_FUNCTION)
Call midiInStart(ri)
End Function
Public Sub EndMidiRecieve()
Call midiInReset(ri)
Call midiInStop(ri)
Call midiInClose(ri)
End Sub
Public Function MidiIn_Event(ByVal MidiInHandle As Long,
ByVal Message As Long, ByVal Instance As Long,
ByVal dw1 As Long, ByVal dw2 As Long) As Long
'dw1 contains the midi code
If dw1 > 255 Then 'Ignore time codes
Call MsgBox(dw1) 'This part is unstable
End If
End Function
The problem is probably MsgBox:
Since the MIDI events use callbacks they are most likely run from another thread. VBA is inherently single-threaded (see e.g. Multi-threading in VBA), so trying to show a modal dialog from another thread will likely cause issues (undefined behavior, crash, anything else...)
MIDI usually triggers huge amounts of events (the tiniest movement of a slider or knob would trigger an event), so moving something a noticeable amount may cause hundreds of events. Showing a dialog (requiring an OK click) at each event could be a problem.
For testing, try to replace Call MsgBox(dw1) with Debug.Print dw1 so that the values are just printed in the Immediate Window, which should be much more stable. If you are trying to execute some simple action (e.g. update the value in a cell, scroll the window) you may be able to get away with it as long as each call to MidiIn_Event completes before the next event.
A much more complex but stable solution could be to push data points onto a queue in the event handler, and use a repeating timer in VBA that pops items from the queue and executes some action on the VBA thread.
This is so fantasticly cool :D
but the message box as mentioned above will kill it, but removing the messagebox will probably not help that much. You want to minimize the abount of traffic to excel too because the vba->excel will not be instantanious.
Soooo the solution would be
on workbook start macro
Public lngMessage As String
Private Sub Workbook_Open()
alertTime = Now + TimeValue("00:00:01")
Application.OnTime alertTime, "EventMacro"
End Sub
Sub EventMacro()
ActiveSheet.Cells(1, 1).Value = lngMessage
alertTime = Now + TimeValue("00:00:01")
End Sub
Public Function MidiIn_Event(ByVal MidiInHandle As Long, ByVal Message As Long, ByVal Instance As Long, ByVal dw1 As Long, ByVal dw2 As Long) As Long
'dw1 contains the midi code
If dw1 > 255 Then 'Ignore time codes
lngMessage = dw1 'This part is now happy
End If
End Function
You need a general Function that processes the data given by the MidiIn_Event one, in my example bellow that function is the runClock() one.
I did this that is able the uses the status bar to count the keys and clock type of messages.
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
Public Sub runClock()
'When canceled become able to close opened Input devices (For ESC press)
On Error GoTo handleCancel
Application.EnableCancelKey = xlErrorHandler
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
'.DisplayStatusBar = False
'.EnableEvents = False
End With
mlngCurDevice = 8 'My Device is 8 but yours is 0
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 And Notes < 10
'Sleep if needed
Sleep 10
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
Call midiInReset(mlngHmidi)
Call midiInStop(mlngHmidi)
Loop
'Closes Input device
Do While midiInClose(mlngHmidi) <> 0
Loop
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
.DisplayStatusBar = True
.EnableEvents = True
End With
MsgBox "ENDED WITH SUCCESS", , "Message:"
'Close all opened MIDI Inputs when canceled (ESC key pressed)
handleCancel:
If Err.Number = 18 Then
'Ends lisingting the MIDI input
Call midiInReset(mlngHmidi)
Call midiInStop(mlngHmidi)
Do While midiInClose(mlngHmidi) <> 0
Loop
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
.DisplayStatusBar = True
.EnableEvents = True
End With
MsgBox "ENDED WITH SUCCESS", , "Message:"
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
'The value 963 is the MIM_DATA concerning regular MIDI messages
If Message = 963 Then
LongMessage = Message
If dw1 > 255 Then
Notes = Notes + 1
Else
ClockTicks = ClockTicks + 1
End If
End If
End Function
The issue comes when ESC key is presses while receiving MIDI data, like clock sync, for some reason, and despite everything else works well, the ESC key many times crashes the script. However if you don't use the ESC key during input MIDI messages you will not have this problem.
Nevertheless I would like to know why pressing the ESC key while receiving clock signals crashes the script.
You just need to adapt the global variable to your needs.
Hope I have helped.

Resources