Summary:
I have VBA code that collects lots of info and writes it out into one or more worksheets. To improve perf writing lots of info into sheets, I created a class that acts kind of like a buffered copy/paste stream: the caller sends it CSV format strings which it buffers in memory until the buffer is full; when full, it pastes into a sheet, clears the buffer and continues.
Initially, I used Global memory, but then saw on MSDN a recommendation to use Heap rather than Global or Local due to less overhead. So now I'm using Heap.
I'm in the process of adapting everything for 64-bit Office. After doing all the PtrSafe stuff, I can run the code. But now Excel crashes when HeapFree() is called.
Question: Why is it crashing, and what do I need to change to avoid it?
Details:
I've come up with the following that is a minimized sample that repro's the crash: there's a module with a sub I can run for the repro, and the class. This doesn't do the buffering; every call to .SendText will put the text on the clipboard and paste into the active cell.
First the module. This has the following declare statements
' memory APIs
Public Const HEAP_ZERO_MEMORY = &H8
Declare PtrSafe Function GetProcessHeap Lib "kernel32" () As LongPtr 'returns HANDLE
Declare PtrSafe Function HeapAlloc Lib "kernel32" (ByVal hHeap As LongPtr, ByVal dwFlags As Long, ByVal dwBytes As LongPtr) As LongPtr 'returns HANDLE
Declare PtrSafe Function HeapFree Lib "kernel32" (ByVal hHeap As LongPtr, ByVal dwFlags As Long, lpMem As Any) As Long 'returns BOOL
Declare PtrSafe Function lstrcpy Lib "kernel32" Alias "lstrcpyW" (ByVal lpDestString As Any, ByVal lpSrcString As Any) As LongPtr 'returns HANDLE
' clipboard APIs
Public Const CF_UNICODETEXT = 13
Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long 'returns BOOL
Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long 'returns BOOL
Declare PtrSafe Function CloseClipboard Lib "user32" () As Long 'returns BOOL
Declare PtrSafe Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As LongPtr) As LongPtr 'returns HANDLE
Then the sub:
Private Sub TestMemoryBugRepro()
Dim s As String
Dim clip As clsHeapBugRepro
s = Chr(34) & "a" & vbLf & "b" & Chr(34) & ",c" & vbCrLf & "d" & vbTab & ",e" & vbCrLf
Set clip = New clsHeapBugRepro
clip.Initialize &H100
clip.SendText s
'Crash happens during the following
Set clip = Nothing
End Sub
Now the class. The crash occurs during Class_Terminate() when HeapFree is called.
Option Explicit
Private m_hHeap As LongPtr 'handle to the process heap
Private m_hMem As LongPtr 'handle to memory
Private m_pMem As LongPtr 'pointer to locked memory
Private m_cbMem As Long 'size of the memory buffer
Private m_BytesWritten As Long '
'**************************************
' Event procedures
Private Sub Class_Initialize()
m_hHeap = GetProcessHeap()
End Sub
Private Sub Class_Terminate()
If m_hMem <> 0 And m_hHeap <> 0 Then
HeapFree m_hHeap, 0, m_hMem 'CRASH OCCURS HERE
End If
End Sub
'**************************************
' Public methods
Public Function Initialize(Optional bufferSize As Long = &H8000) As Boolean
Initialize = False
m_BytesWritten = 0
If m_hHeap <> 0 Then
m_cbMem = bufferSize
m_hMem = HeapAlloc(m_hHeap, (HEAP_ZERO_MEMORY), m_cbMem)
End If
If m_hMem <> 0 Then Initialize = True
End Function
Public Function SendText(text As String) As Boolean
Dim nStrLen As Long
nStrLen = LenB(text) + 2&
Debug.Assert nStrLen < (m_cbMem + m_BytesWritten)
m_pMem = m_hMem 'in lieu of locking heap memory
lstrcpy m_pMem, StrPtr(text)
m_pMem = 0 'in lieu of unlocking heap memory
m_BytesWritten = m_BytesWritten + nStrLen
DoEvents
OpenClipboard 0&
EmptyClipboard
SetClipboardData CF_UNICODETEXT, m_hMem
CloseClipboard
ActiveCell.PasteSpecial
DoEvents
SendText = True
End Function
There's an issue in how you're calling HeapFree, but your real issue is that you shouldn't be using HeapAlloc/HeapFree at all.
Memory allocated by HeapAlloc is not movable, whereas SetClipboardData requires it to be moveable.
Another consideration is that SetClipboardData transfers the ownership of the memory to the system, which means you should not free it yourself. (The application may not write to or free the data once ownership has been transferred to the system.)
So, I would try to rewrite your logic using GlobalAlloc, not HeapAlloc, and don't try to free memory after it is put on the clipboard.
Now, there was an issue in how you were calling HeapFree, if you were going to use it. HeapFree wants the pointer returned by HeapAlloc.
You were instead passing a pointer to that pointer, because you declared the third argument of HeapFree As Any, which means ByRef As Any.
Either redeclare the argument ByVal As LongPtr / ByVal As Any, e.g.:
Declare PtrSafe Function HeapFree Lib "kernel32" (ByVal hHeap As LongPtr, _
ByVal dwFlags As Long,
ByVal lpMem As LongPtr) As Long 'returns BOOL
or specify ByVal when calling it:
HeapFree m_hHeap, 0, ByVal m_hMem
Related
I'm facing an issue in Excel from Office365. Since the switch to the current Excel 365, the code below no longer works as soon as the callback function is packed into a separate module.
The code (it's pure sample code) is in a module. Sub doAction() is executed with F5. A timer is created, waits for 1150 ms and then the timer is deleted again. The timer calls TimerCallback and about 10 messages appear in the immediate window.
Here is the sample code:
Option Explicit
Public Const cCallbackIntervall = 100
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 PtrSafe Function GetTickCount _
Lib "kernel32" Alias "GetTickCount64" () As LongLong
Public Sub waitMilliseconds(lPeriod As Long)
Dim lTickcount As LongLong
lTickcount = GetTickCount
Do While GetTickCount - lTickcount < lPeriod
DoEvents
Loop
End Sub
Public Sub TimerCallback(ByVal hWnd As LongPtr, ByVal uMsg As LongPtr, _
ByVal wParam As LongPtr, ByVal lParam As LongPtr)
On Error Resume Next
Debug.Print "Huhu " & Str(Timer)
End Sub
Sub doAction()
Dim lTimer As LongPtr
Debug.Print
lTimer = SetTimer(0, 0, cCallbackIntervall, AddressOf TimerCallback)
waitMilliseconds (1150)
lTimer = KillTimer(0, lTimer)
End Sub
As soon as the TimerCallback procedure is packed into its own module, the entire Excel crashes.
Has anyone an idea of the reasons why?
I did a small script that works extremely well on any computer with Excel version 32bits, and becomes extremely sluggish on Excel version 64bits on the same computer where an Excel version 32bits was successfully tried!
This is extremely puzzling, besides being unpredictable on 64bits, when it works it stops almost always after 33 seconds. This duration on the 64bits is consistent among different BPM tested from 20 up to 300bpm, above that tempo the VBA script stops or crashes! I suspect it has something to do with memory. However the MidiIn_Event becomes so sluggish on 64bits that it may be a bug on Windows itself!
UPDATE: The script below breaks out the cycle Do While countdown > 0 despite the countdown being greater than 0! So, something is disrupting the cycle while before the countdown reaches zero (for 64bits only).
This is the script:
Option Explicit
Private Const CALLBACK_FUNCTION = &H30000
'INPUT DEVICE ID ENTERED HERE
Private Const MIDI_DEVICE_ID As Long = 1
'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 Any, ByVal dwInstance As LongPtr, ByVal dwFlags 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 Any, ByVal dwInstance As Long, ByVal dwFlags 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 mlngHmidi As LongPtr
Private mlngRc As LongPtr
Private mlngMidiMsg As LongPtr
#Else
Private mlngHmidi As Long
Private mlngRc As Long
Private mlngMidiMsg As Long
#End If
'Counters
Private countdown As Integer
Private function_calls As Integer
Private function_actions As Integer
Private pendent_goes As Integer
'Main Function externally Called
Public Sub runClock()
'When canceled become able to close opened MIDI Channels!
On Error GoTo handleCancel
Application.EnableCancelKey = xlErrorHandler
'Counters Reset
countdown = 5000 'Press Esc to Stop
function_calls = 0
function_actions = 0
pendent_goes = 0
'Starts listening the Midi Input
Call midiInOpen(mlngHmidi, MIDI_DEVICE_ID - 1, AddressOf MidiIn_Event, 0, CALLBACK_FUNCTION)
Call midiInStart(mlngHmidi)
Application.StatusBar = "Started"
'Processes the Countdown for each Midi Message
Do While countdown > 0
If pendent_goes > 0 Then
'Shows up the counting down each time a Midi Message is processed
Application.StatusBar = "Countdown=" & countdown & " | Pendent=" & pendent_goes
countdown = countdown - 1
pendent_goes = pendent_goes - 1
End If
Loop
'Ends listening the Midi Input
Call midiInReset(mlngHmidi)
Call midiInStop(mlngHmidi)
Call midiInClose(mlngHmidi)
'Shows the total amount of calls and the amount of messages processed
Application.StatusBar = "Finish (" & function_calls & ", " & function_actions & ")"
handleCancel: 'Handles the Esc key
If Err.Number = 18 Then
'Ends listening the Midi Input
Call midiInReset(mlngHmidi)
Call midiInStop(mlngHmidi)
Call midiInClose(mlngHmidi)
'Shows the total amount of calls and the amount of messages processed
Application.StatusBar = "Finish (" & function_calls & ", " & function_actions & ")"
End If
End Sub
'CALLBACK FUNCTION PROCESSED ON EACH MIDI MESSAGE GIVENT BY THE INPUT DEVICE
Private Sub MidiIn_Event(ByVal mlngHmidi As LongPtr, ByVal Message As LongPtr, ByVal instance As LongPtr, ByVal dw1 As LongPtr, ByVal dw2 As LongPtr)
'Excel 32bit: Works without any problem up to 600bpm;
'Excel 64bit: Sluggish, doesn't work more than 33 seconds and crashes a lot!
function_calls = function_calls + 1 'Counts all Calls
If Message = 963 Then
function_actions = function_actions + 1 'Counts all Message Inputs
pendent_goes = pendent_goes + 1 'Adds quantity of Messages to be processed
End If
End Sub
I would like to know how to make it work on Excel 64bits like it works on 32bits.
For testing I use the MIDI-OX to generate the Clock Sync midi messages and the loopMIDI as the midi Device input.
Any help is appreciated. Thanks.
This is the last updated code accordingly to suggestions with the following results:
Still disrupts the While cycle for 64bit excel;
Added the version const, now the VBA7 makes it true even for 32 bit
Excel versions. Nevertheless the Excel 32bit still works fine.
Updated Script:
Option Explicit
Private Const CALLBACK_FUNCTION = &H30000
'INPUT DEVICE ID ENTERED HERE
Private Const MIDI_DEVICE_ID As Long = 1
'MIDI Functions here: https://learn.microsoft.com/en-us/windows/win32/multimedia/midi-functions
#If VBA7 Then
Private Const BIT_VERSION = 64
'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" (ByRef lphMidiIn As LongPtr, ByVal uDeviceID As Long, ByVal dwCallback As LongPtr, ByVal dwInstance As LongPtr, ByVal dwFlags As Long) 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 Const BIT_VERSION = 32
'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 Any, ByVal dwInstance As Long, ByVal dwFlags 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 VBA7 Then
Private mlngHmidi As LongPtr
Private mlngRc As LongPtr
Private mlngMidiMsg As LongPtr
#Else
Private mlngHmidi As Long
Private mlngRc As Long
Private mlngMidiMsg As Long
#End If
'Counters
Private countdown As Integer
Private function_calls As Integer
Private function_actions As Integer
Private pendent_goes As Integer
'Main Function externally Called
Public Sub runClock()
'When canceled become able to close opened MIDI Channels!
On Error GoTo handleCancel
Application.EnableCancelKey = xlErrorHandler
'Counters Reset
countdown = 5000 'Press Esc to Stop
function_calls = 0
function_actions = 0
pendent_goes = 0
'Starts listening the Midi Input
Call midiInOpen(mlngHmidi, MIDI_DEVICE_ID - 1, AddressOf MidiIn_Event, 0, CALLBACK_FUNCTION)
Call midiInStart(mlngHmidi)
Application.StatusBar = "Started"
'Processes the Countdown for each Midi Message
Do While countdown > 0
If pendent_goes > 0 Then
'Shows up the counting down each time a Midi Message is processed
Application.StatusBar = "VERSION=" & BIT_VERSION & " | " & "Countdown=" & countdown & " | Pendent=" & pendent_goes
countdown = countdown - 1
pendent_goes = pendent_goes - 1
End If
Loop
'Ends listening the Midi Input
Call midiInReset(mlngHmidi)
Call midiInStop(mlngHmidi)
Call midiInClose(mlngHmidi)
'Shows the total amount of calls and the amount of messages processed
Application.StatusBar = "Finish (" & function_calls & ", " & function_actions & ")"
handleCancel: 'Handles the Esc key
If Err.Number = 18 Then
'Ends listening the Midi Input
Call midiInReset(mlngHmidi)
Call midiInStop(mlngHmidi)
Call midiInClose(mlngHmidi)
'Shows the total amount of calls and the amount of messages processed
Application.StatusBar = "Finish (" & function_calls & ", " & function_actions & ")"
End If
End Sub
'CALLBACK FUNCTION PROCESSED ON EACH MIDI MESSAGE GIVENT BY THE INPUT DEVICE
Private Sub MidiIn_Event(ByVal mlngHmidi As LongPtr, ByVal Message As Long, ByVal instance As LongPtr, ByVal dw1 As LongPtr, ByVal dw2 As LongPtr)
'Excel 32bit: Works without any problem up to 600bpm;
'Excel 64bit: Sluggish, doesn't work more than 33 seconds and crashes a lot!
function_calls = function_calls + 1 'Counts all Calls
If Message = 963 Then
function_actions = function_actions + 1 'Counts all Message Inputs
pendent_goes = pendent_goes + 1 'Adds quantity of Messages to be processed
End If
End Sub
I have a process that requires an active VPN connection, but the connection is automatically cut every 8 hours. I need to be able to control that the connection is active and the time left up to the 8 hour limit.
In the properties of the windows connections the time appears (attached capture with the data that I need), but I need to know how to read this data.
Try the next approach, please:
Edited, because of the last request:
Please add two new declarations
Copy the next API functions on top of a standard module:
Option Explicit
Private Declare PtrSafe Function FindWindow Lib "User32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Private Declare PtrSafe Function FindWindowEx Lib "User32" Alias "FindWindowExA" (ByVal hWnd1 As LongPtr, _
ByVal hWnd2 As LongPtr, ByVal lpsz1 As String, ByVal lpsz2 As String) As LongPtr
Private Declare PtrSafe Function SendMessage Lib "User32" Alias "SendMessageA" (ByVal hwnd As LongPtr, _
ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Any) As Long
Private Declare PtrSafe Function GetWindowTextLength Lib "User32" Alias "GetWindowTextLengthA" (ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function GetWindowText Lib "User32" Alias "GetWindowTextA" (ByVal hwnd As LongPtr, _
ByVal lpString As String, ByVal cch As Long) As Long
Private Declare PtrSafe Function GetWindow Lib "User32" (ByVal hwnd As LongPtr, ByVal wCmd As Long) As Long
And the next Constant:
Private Const GW_HWNDNEXT = 2
'Added after editing:__________________
Private Const WM_LBUTTON_DOWN = &H201
Private Const BM_CLICK = &HF5
'______________________________________
In the same standard module, copy the next Sub. Please, take care to change Duration: from the code, with the Spanish correct variant ('Duración' [with the necessary accent]):
Sub DurationAPI()
Dim hwndEth As LongPtr, hwndGen As LongPtr, hwndDurlbl As LongPtr, hwndDur As LongPtr
Dim sStr As String, strWindowTitle As String, durationLbl As String, durT As Date, limitD As Date
'added after editing:_____________________________
OpenWiFiConnectionWindow 'open connection window
AppActivate Application.ActiveWindow.Caption
'_________________________________________________
limitD = CDate("08:00:00")
strWindowTitle = "Estado de Wi-Fi"
durationLbl = "Duration:" 'Please change here with your exact label title (in Spanish...)
'I cannot write duracion: with the necessary accent...
hwndEth = FindWindow(vbNullString, strWindowTitle): Debug.Print Hex(hwndEth)
hwndGen = FindWindowEx(hwndEth, 0&, vbNullString, "General"): Debug.Print Hex(hwndGen)
hwndDurlbl = FindWindowEx(hwndGen, 0&, vbNullString, durationLbl): Debug.Print Hex(hwndDurlbl)
hwndDur = GetWindow(hwndDurlbl, GW_HWNDNEXT): Debug.Print Hex(hwndDur)
sStr = String(GetWindowTextLength(hwndDur) + 1, Chr$(0))
GetWindowText hwndDur, sStr, Len(sStr)
durT = CDate(sStr)
MsgBox Format(limitD - durT, "hh:mm:ss") & " left until connection will be interrupted!", _
vbInformation, "Time to connection interruption"
'Added after editing: ____________________________________________________
Dim hwndClose As LongPtr
'closing the connection window:
hwndClose = FindWindowEx(hwndEth, 0&, vbNullString, "&Close"): Debug.Print Hex(hwndClose)
SendMessage hwndClose, WM_LBUTTON_DOWN, 0&, 0&
SendMessage hwndClose, BM_CLICK, 0, ByVal 0&
'_________________________________________________________________________
End Sub
bis Copy the Sub able to show the necessary connection window:
Private Sub OpenWiFiConnectionWindow()
Dim objApp As Object: Set objApp = CreateObject("Shell.Application")
Dim objFolder As Object: Set objFolder = objApp.Namespace(&H31&).self.GetFolder
Dim interface As Variant, interfaceTarget As Object, InterfaceName As String
InterfaceName = "Wi-Fi" 'Please, check here what is show your "Network Connections" folder. It maybe can be slightly different...
'I tested the code on my Ethernet connection, which not was simple "Ethernet". It was "Ethernet 2"...
For Each interface In objFolder.Items
If LCase(interface.Name) = LCase(InterfaceName) Then
Set interfaceTarget = interface: Exit For
End If
Next
Dim Verb As Variant
For Each Verb In interfaceTarget.Verbs
If Verb.Name = "Stat&us" Then
Verb.DoIt
Application.Wait Now + TimeValue("0:00:01")
Exit For
End If
Next
End Sub
Please, try this Sub first, in order to be sure that it shows the necessary connection window. If it doesn't, please look in the "Network Connections" folder and change InterfaceName with an appropriate one.
Run the above DurationAPI() Sub.
All the necessary windows handlers are returned in Immediate window. If one of them is 0 (zero), there must be checked to understand what is happening... I used Spy++ to find the windows titles/classes...
For a window with English titles, it returns correctly and almost instant the necessary connection duration time.
I found that post investigating, but unfortunately not answering the question which came to my mind on
HOW TO EXPORT GRAPHS FROM EXCEL AS *.EMF
Excel export chart to wmf or emf?
The code presented is not working for me.
What I did is to extend each "Private Declare Function" like this "Private Declare PtrSafe Function" to make it applicable for 64BIT.
CODE:
Option Explicit
Private Declare PtrSafe Function OpenClipboard _
Lib "user32" ( _
ByVal hwnd As Long) _
As Long
Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
Private Declare PtrSafe Function GetClipboardData _
Lib "user32" ( _
ByVal wFormat As Long) _
As Long
Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
'// CreateMetaFileA DeleteEnhMetaFile
Private Declare PtrSafe Function CopyEnhMetaFileA _
Lib "gdi32" ( _
ByVal hENHSrc As Long, _
ByVal lpszFile As String) _
As Long
Private Declare PtrSafe Function DeleteEnhMetaFile _
Lib "gdi32" ( _
ByVal hemf As Long) _
As Long
Public Function fnSaveAsEMF(strFileName As String) As Boolean
Const CF_ENHMETAFILE As Long = 14
Dim ReturnValue As Long
OpenClipboard 0
ReturnValue = CopyEnhMetaFileA(GetClipboardData(CF_ENHMETAFILE), strFileName)
EmptyClipboard
CloseClipboard
'// Release resources to it eg You can now delete it if required
'// or write over it. This is a MUST
DeleteEnhMetaFile ReturnValue
fnSaveAsEMF = (ReturnValue <> 0)
End Function
Sub SaveIt()
Charts.Add
ActiveChart.ChartArea.Select
Selection.Copy
If fnSaveAsEMF("C:\Excel001.emf") Then
MsgBox "Saved", vbInformation
Else
MsgBox "NOT Saved!", vbCritical
End If
I want to use this code to export graphs from worksheets with their worksheet name automatically to a specific folder within a loop in case thats possible. Highlight would be if its possible to execute that via a button.
So far when i run the code All I get is a "NOT SAVED" message. Im using Excel 365 ProPlus, in case thats of any relevance.
I would highly appreciate if someone would explain me how this code is working and what i need to implement there
The OP code worked for me after commenting out the Charts.add line and changing the write destination to a path where I had write privileges
Option Explicit
Private Declare PtrSafe Function OpenClipboard _
Lib "user32" ( _
ByVal hwnd As Long) _
As Long
Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
Private Declare PtrSafe Function GetClipboardData _
Lib "user32" ( _
ByVal wFormat As Long) _
As Long
Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
'// CreateMetaFileA DeleteEnhMetaFile
Private Declare PtrSafe Function CopyEnhMetaFileA _
Lib "gdi32" ( _
ByVal hENHSrc As Long, _
ByVal lpszFile As String) _
As Long
Private Declare PtrSafe Function DeleteEnhMetaFile _
Lib "gdi32" ( _
ByVal hemf As Long) _
As Long
Public Function fnSaveAsEMF(strFileName As String) As Boolean
Const CF_ENHMETAFILE As Long = 14
Dim ReturnValue As Long
OpenClipboard 0
ReturnValue = CopyEnhMetaFileA(GetClipboardData(CF_ENHMETAFILE), strFileName)
EmptyClipboard
CloseClipboard
'// Release resources to it eg You can now delete it if required
'// or write over it. This is a MUST
DeleteEnhMetaFile ReturnValue
fnSaveAsEMF = (ReturnValue <> 0)
End Function
Sub SaveIt()
'Charts.Add
ActiveChart.ChartArea.Select
Selection.Copy
If fnSaveAsEMF("m:\mpo\autompo\test.emf") Then 'the name excluding the .emf can be changed
'Be sure you have write privileges here or you will get an error
MsgBox "Saved", vbInformation
Else
MsgBox "NOT Saved!", vbCritical
End If
End Sub
This is effectively the same answer as #kuv , but adds in the PtrSafe modifier to the windows function calls (these are required with 64 bit excel.
this is some code that i have used, the user32 function which imitates human interaction directly is the only way ive come across to save chats as different formats via vba, also its current statements are for an active sheet/workbook which can obviously be altered if you building a dashboard where the charts remain on other sheets, if you have any queries you can email me on howtovba#gmail.com;
Option Explicit
Private Declare Function OpenClipboard _
Lib "user32" ( _
ByVal hwnd As Long) _
As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function GetClipboardData _
Lib "user32" ( _
ByVal wFormat As Long) _
As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
'// CreateMetaFileA DeleteEnhMetaFile
Private Declare Function CopyEnhMetaFileA _
Lib "gdi32" ( _
ByVal hENHSrc As Long, _
ByVal lpszFile As String) _
As Long
Private Declare Function DeleteEnhMetaFile _
Lib "gdi32" ( _
ByVal hemf As Long) _
As Long
Public Function fnSaveAsEMF(strFileName As String) As Boolean
Const CF_ENHMETAFILE As Long = 14
Dim ReturnValue As Long
OpenClipboard 0
ReturnValue = CopyEnhMetaFileA(GetClipboardData(CF_ENHMETAFILE), strFileName)
EmptyClipboard
CloseClipboard
'// Release resources to it eg You can now delete it if required
'// or write over it. This is a MUST
DeleteEnhMetaFile ReturnValue
fnSaveAsEMF = (ReturnValue <> 0)
End Function
Sub SaveIt()
Charts.Add
ActiveChart.ChartArea.Select
Selection.Copy
If fnSaveAsEMF("C:\Excel001.emf") Then 'the name excluding the .emf can be changed
MsgBox "Saved", vbInformation
Else
MsgBox "NOT Saved!", vbCritical
End If
End Sub
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.