search

cristianbuse / VBA-FastExcelUDFs

Excel User Defined Functions (VBA) run faster
MIT License
14 stars 5 forks source link

Oddly enough, the FindWindow API will do this quickly. #3

Closed SanbiVN closed 2 months ago

SanbiVN commented 3 months ago

Hi @cristianbuse You just need to call FindWindow API in the function and the calculation process will be fast, you try to check it.

#If VBA7 Then
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
#Else
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
#End If

Public Function TEST_UDF(value As Boolean) As Variant
  Call FindWindow("", "")
  TEST_UDF = value
End Function

Public Function TEST_UDF2(value As Boolean) As Variant
   Call FindWindow("", "")
    TEST_UDF2 = value
End Function

I would really like a chance to chat with you via social media, what do you think?

cristianbuse commented 3 months ago

Hi @SanbiVN ,

Thanks. I won't have access to a computer for the next 2 weeks but I will test this then.

Feel free to write me at cristian.buse@yahoo.com

Cheers

cristianbuse commented 2 months ago

Hi @SanbiVN

Just tested this and for 10000 formulas, the FindWindow takes over 3 seconds while the current TriggerFastUDFCalculation approach takes only a few milliseconds.

Thanks!

SanbiVN commented 2 months ago

cristianbuse,

When testing on my computer, with FindWindow sometimes with 40k formulas, it only takes a few milliseconds, but sometimes it takes a few seconds. And I tried your method, it always takes more than 1 to a few seconds. My computer uses a Ryzen 7 CPU.

cristianbuse commented 2 months ago

@SanbiVN

My solution does two things: 1) it forces Excel out of UDF mode to avoid the flickering bug 2) it runs a loop until the Application.CalculationState is equal to xlDone

For a large number of UDFs, it is critical that the calculation is done outside of UDF mode hence the 2 step solution. The disadvantage with this approach is that if you happen to have volatile functions in your opened workbooks (e.g. OFFSET, INDIRECT, TODAY etc.) then those will also get calculated and sometimes lead to another bug which keeps the state at xlPending. So, I never use volatile functions - this could be why you're seeing different results. I am curious, how long does my solution take on your computer, if you run the demo workbook dropdowns, without having other workbooks open?

I have not tested your solution on x32 but on x64 there is an API overhead which might be why it's taking so long for me to run.

SanbiVN commented 2 months ago

@cristianbuse

In your solution: SendInput only executes on the current window. So stopping the calculation with this method will not be correct, when the current window is another window.

The PostMessage command can execute to close the UserForm, when the Application stops calculating when writing the calculation phase message Calculating:(xx Processor(s)): xx%. When I print LastCallerRange with 40,000 expressions, the last cell address is near the end of 40,000. That means the process of exiting UDF mode is quite late. I see that the stronger the CPU configuration, the later the process of exiting UDF mode.

I don't understand what you mean by "exiting UDF mode". So if you exit earlier, will it be more effective?

With Application.Volatile, as I understand, it only works on the UDF containing this command when set to TRUE. Any change in the value or cell containing the formula forces that UDF to calculate. With the two test functions, you have set Application.Volatile False, which seems like a redundant line of code, even when volatile functions are called.

cristianbuse commented 2 months ago

@SanbiVN

SendInput only executes on the current window. So stopping the calculation with this method will not be correct, when the current window is another window.

It does not matter what window. It only needs to do a calculation interrupt.

The PostMessage command can execute to close the UserForm, when the Application stops calculating when writing the calculation phase message Calculating:(xx Processor(s)): xx%. When I print LastCallerRange with 40,000 expressions, the last cell address is near the end of 40,000. That means the process of exiting UDF mode is quite late. I see that the stronger the CPU configuration, the later the process of exiting UDF mode.

Not all PostMessage calls will be processed. However, if all UDFs have this on, then eventually one will trigger. The rest are ignored anyway. The idea is to run a single FastCalculate per calculation session, regardless if in that session are 40000 UDF calls or just one. When the number is low, like a single UDF call, then it does not really matter if the trigger does not work - because the whole goal of this repo is to make lots of calls run faster.

I don't understand what you mean by "exiting UDF mode". So if you exit earlier, will it be more effective?

Maybe this article will give you a better idea.

With Application.Volatile, as I understand, it only works on the UDF containing this command when set to TRUE. Any change in the value or cell containing the formula forces that UDF to calculate. With the two test functions, you have set Application.Volatile False, which seems like a redundant line of code, even when volatile functions are called.

All my UDFs have Application.Volatile = False. The default is True as per Microsoft. If the line is missing, or is explicitly set to True then all the cells containing that UDF will recalculate all the time (the definition of volatility), even if the change happened somewhere eles completely unrelated to the cell. If you haven't read this, then you should - I highly reccomend you do.

SanbiVN commented 2 months ago

@cristianbuse

The code below I saw Jaafar share on MrExcel forum. It is capable of triggering VBA function calls even when UDFs are in the process of calculating. I tested with 40,000 expressions, and LastCell is located in a cell not far from the starting position.

The method below turns on event listening for an API call. Here I choose the rtcDoEvents method in VBE7.Dll. The RedirectWaitingProcCalled function will be called, when the DoEvents method is called in VBA.

Do you consider this option feasible in your project.

Before applying the below code for testing, you need to add a condition so that the event is not fired a second time.

  onWaitingProcCalled "VBE7.dll", "rtcDoEvents": DoEvents
Option Explicit

#If VBA7 = 0 Then
  Private Enum LongLong:[_]:End Enum
  Private Enum LongPtr:[_]:End Enum
#End If
#If Win64 Then
  Private Const PTR_LEN = 8&
#Else
  Private Const PTR_LEN = 4&
#End If

Private Const NULL_PTR As LongPtr = 0
Private Const UPPER_BOUND = PTR_LEN * 1.5
Private Type HOOK_DATA
  OriginBytes(0& To UPPER_BOUND - 1) As Byte
  HookBytes(0& To UPPER_BOUND - 1) As Byte
  pFunc As LongPtr
  pHooker As LongPtr
End Type

#If VBA7 Then
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
Private Declare PtrSafe Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String, ByVal hData As LongPtr) As Long
Private Declare PtrSafe Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
Private Declare PtrSafe Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
Private Declare PtrSafe Function GetCurrentThreadId Lib "kernel32" () As Long
Private Declare PtrSafe Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As LongPtr
Private Declare PtrSafe Function GetProcAddress Lib "kernel32" (ByVal hModule As LongPtr, ByVal lpProcName As String) As LongPtr
Private Declare PtrSafe Function VirtualProtect Lib "kernel32.dll" (ByVal lpAddress As LongPtr, ByVal dwSize As LongPtr, ByVal flNewProtect As Long, lpflOldProtect As Long) As Long
Private Declare PtrSafe Function LoadLibrary Lib "kernel32" Alias "LoadLibraryW" (ByVal lpLibFileName As LongPtr) As LongPtr
Private Declare PtrSafe Function EnumThreadWindows Lib "user32" (ByVal dwThreadId As Long, ByVal lpfn As LongPtr, lParam As LongPtr) As Long
Private Declare PtrSafe Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As LongPtr, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
#Else
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As Long, ByVal lpString As String, ByVal hData As Long) As Long
Private Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
Private Declare Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long
Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
Private Declare Function VirtualProtect Lib "kernel32.dll" (ByVal lpAddress As Long, ByVal dwSize As Long, ByVal flNewProtect As Long, lpflOldProtect As Long) As Long
Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryW" (ByVal lpLibFileName As Long) As Long
Private Declare Function EnumThreadWindows Lib "user32" (ByVal dwThreadId As Long, ByVal lpfn As Long, lParam As Long) As Long
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
#End If

' _______________________________________ PRIVATE ROUTINES __________________________________________
Private Sub onWaitingProcCalled_test()
  onWaitingProcCalled "VBE7.dll", "rtcDoEvents": DoEvents
End Sub

Private Function RedirectWaitingProcCalled() As Long
  On Error GoTo ErrHandler
  Call stopWaitingProcCalled
  Debug.Print "RedirectDelegate "; Timer
Exit Function
ErrHandler:
End Function

Private Sub onWaitingProcCalled(ByVal moduleName$, ByVal ProcName$)
  Const PAGE_EXECUTE_READWRITE As Long = &H40&
  Dim hData As HOOK_DATA, hmod As LongPtr, OriginProtect As Long, i As Long, h As LongPtr
  h = iiiVBEHandle
  If GetProp(h, "FuncPtr") Then Call stopWaitingProcCalled
  With hData 'LoadLibrary
    hmod = GetModuleHandle(moduleName): If hmod = 0 Then If LoadLibrary(StrPtr(moduleName)) = 0 Then Exit Sub
    .pFunc = GetProcAddress(hmod, ProcName): If .pFunc = 0 Then Exit Sub
    Call SetProp(h, "FuncPtr", .pFunc)
    If VirtualProtect(ByVal .pFunc, UPPER_BOUND, PAGE_EXECUTE_READWRITE, OriginProtect) = 0& Then Exit Sub
    Call CopyMemory(ByVal VarPtr(.OriginBytes(0&)), ByVal .pFunc, UPPER_BOUND)
    For i = 0 To UPPER_BOUND - 1
      Call SetProp(h, "OrignPtr" & i, .OriginBytes(i))
    Next i
    .pHooker = Choose(1&, AddressOf RedirectWaitingProcCalled)
    #If Win64 Then
      .HookBytes(0&) = &H48
      .HookBytes(1&) = &HB8: Call CopyMemory(.HookBytes(2&), .pHooker, PTR_LEN)
      .HookBytes(10&) = &HFF
      .HookBytes(11&) = &HE0
    #Else
      .HookBytes(0&) = &H68: Call CopyMemory(.HookBytes(1&), .pHooker, PTR_LEN)
      .HookBytes(5&) = &HC3
    #End If
    Call CopyMemory(ByVal .pFunc, ByVal VarPtr(.HookBytes(0&)), UPPER_BOUND)
  End With
End Sub
Private Sub stopWaitingProcCalled()
  Dim bytes(0& To UPPER_BOUND - 1) As Byte, i As Long, h As LongPtr
  h = iiiVBEHandle
  If GetProp(h, "FuncPtr") Then
    For i = 0& To UPPER_BOUND - 1
      bytes(i) = CByte(GetProp(h, "OrignPtr" & i))
    Next i
    Call CopyMemory(ByVal GetProp(h, "FuncPtr"), ByVal VarPtr(bytes(0&)), UPPER_BOUND)
    Call RemoveProp(h, "FuncPtr")
    Call RemoveProp(h, "OrignPtr")
  End If
End Sub

Private Function iiiVBEHandle() As LongPtr
  Static l As LongPtr
  If l = 0 Then EnumThreadWindows GetCurrentThreadId, AddressOf EnumThreadWndProc, l
  iiiVBEHandle = l
End Function
Private Function EnumThreadWndProc(ByVal hwnd As Long, lParam As LongPtr) As Long
  Dim l1 As Long, h As LongPtr, s1 As String * 100, s$
  l1 = GetClassName(hwnd, s1, 100): s = Left$(s1, l1)
  Select Case s
  Case "wndclass_desked_gsk": lParam = hwnd
  End Select
  EnumThreadWndProc = True
End Function
cristianbuse commented 2 months ago

I don't like this approach. Try this: 1) call onWaitingProcCalled "VBE7.dll", "rtcDoEvents" 2) Edit some code OR insert a new module 3) Call DoEvents This leads to a crash.

I moved away from SetTimer API and into PostMessage precisely because crashes can occur. Thank you for the suggestion! However, if a non-crash solution is available, it makes sense to choose it over the crash solution. Moreover, I would rather use SetTimer instead of hooking like in Jaafar's example.

Finally, if some other code is dependant on DoEvents, then this approach ruins that. It can lead to unexpected side effects

SanbiVN commented 2 months ago

@cristianbuse 

onWaitingProcCalled "VBE7.dll", "rtcDoEvents": DoEvents

This line of code calls DoEvents immediately, causing the event to be closed immediately, so the problem you describe is unlikely.

Below is the Timer code, which can be somewhat safer. I based this code on Jaafar's shared code. Jaafar created a virtual callback function, and swapped memory with the main function. You can test them.

(***create new userform with name ZZZZZUnknownHandleIdEvents)

Private Const ProjectName = "VBSafeTimerStateLoss"
Private Const ProjectVersion = "1.0.0"

Option Explicit

#If VBA7 = 0 Then
  Private Enum LongLong:[_]:End Enum
  Private Enum LongPtr:[_]:End Enum
#End If
#If Win64 Then
  Private Const PTR_LEN = 8&
#Else
  Private Const PTR_LEN = 4&
#End If
Private Const NULL_PTR As LongPtr = 0
Private Const UPPER_BOUND = PTR_LEN * 1.5
Private Type HOOK_DATA
  OriginBytes(0& To UPPER_BOUND - 1) As Byte
  HookBytes(0& To UPPER_BOUND - 1) As Byte
  pFunc As LongPtr
  pHooker As LongPtr
End Type
#If -VBA7 And -Win64 Then
  Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As LongPtr, ByVal lpTimerFunc As LongPtr) As LongPtr
  Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As LongPtr
#ElseIf VBA7 Then
  Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As LongPtr, ByVal lpTimerFunc As LongPtr) As Long
  Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
#Else
  Private Declare Function setTimer Lib "user32" Alias "SetTimer" (ByVal HWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
  Private Declare Function killTimer Lib "user32" Alias "KillTimer" (ByVal HWnd As Long, ByVal nIDEvent As Long) As Long
#End If
#If VBA7 Then
Private Declare PtrSafe Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As Any, ByVal hwnd As LongPtr) As LongPtr
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
Private Declare PtrSafe Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String, ByVal hData As LongPtr) As Long
Private Declare PtrSafe Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
Private Declare PtrSafe Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
Private Declare PtrSafe Function getTickCount Lib "kernel32.dll" Alias "GetTickCount" () As Long
Private Declare PtrSafe Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hwndParent As LongPtr, ByVal hMenu As LongPtr, ByVal hInstance As LongPtr, lpParam As Any) As LongPtr
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Private Declare PtrSafe Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As LongPtr, ByRef lpdwProcessId As Long) As Long
Private Declare PtrSafe Function GetCurrentThreadId Lib "kernel32" () As Long
Private Declare PtrSafe Function DestroyWindow Lib "user32" (ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function IsWindowEnabled Lib "user32" (ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function IsWindow Lib "user32" (ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function GetWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal wCmd As Long) As LongPtr
Private Declare PtrSafe Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As LongPtr
Private Declare PtrSafe Function GetProcAddress Lib "kernel32" (ByVal hModule As LongPtr, ByVal lpProcName As String) As LongPtr
Private Declare PtrSafe Function VirtualProtect Lib "kernel32.dll" (ByVal lpAddress As LongPtr, ByVal dwSize As LongPtr, ByVal flNewProtect As Long, lpflOldProtect As Long) As Long
Private Declare PtrSafe Function LoadLibrary Lib "kernel32" Alias "LoadLibraryW" (ByVal lpLibFileName As LongPtr) As LongPtr
Private Declare PtrSafe Function EnumThreadWindows Lib "user32" (ByVal dwThreadId As Long, ByVal lpfn As LongPtr, lParam As LongPtr) As Long
Private Declare PtrSafe Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As LongPtr, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageW" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Any) As Long
Private Declare PtrSafe Function GetDlgItem Lib "user32" (ByVal hDlg As LongPtr, ByVal nIDDlgItem As Long) As LongPtr
Private Declare PtrSafe Function GetLastActivePopup Lib "user32" (ByVal hwndOwnder As LongPtr) As LongPtr
#Else
Private Declare Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As Any, ByVal hwnd As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As Long, ByVal lpString As String, ByVal hData As Long) As Long
Private Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
Private Declare Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
Private Declare Function getTickCount Lib "kernel32.dll" Alias "GetTickCount" () As Long
Private Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hwndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal Hwnd As Long, ByRef lpdwProcessId As Long) As Long
Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long
Private Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function IsWindowEnabled Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function IsWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wCmd As Long) As Long
Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As LongPtr
Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As LongPtr, ByVal lpProcName As String) As LongPtr
Private Declare Function VirtualProtect Lib "kernel32.dll" (ByVal lpAddress As LongPtr, ByVal dwSize As LongPtr, ByVal flNewProtect As Long, lpflOldProtect As Long) As Long
Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryW" (ByVal lpLibFileName As Long) As Long
Private Declare Function EnumThreadWindows Lib "user32" (ByVal dwThreadId As Long, ByVal lpfn As Long, lParam As Long) 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 SendMessage Lib "user32" Alias "SendMessageW" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function GetDlgItem Lib "user32" (ByVal hDlg As Long, ByVal nIDDlgItem As Long) As Long
Private Declare Function GetLastActivePopup Lib "user32" (ByVal hwndOwnder As Long) As Long
#End If

#If -VBA7 And -Win64 Then
Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
#ElseIf VBA7 Then
Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As Long
#Else
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
#End If

Private Enum idEventUseDefined
  cIdEvent = 103322000
End Enum

Private Sub TestSubNow1()
  Call test_userform
End Sub
Private Sub test_userform()
  'callProcTimer True
  callProcTimer False
  Application.OnTime Now + TimeSerial(0, 0, 1), "'" & ThisWorkbook.Name & "'!test_MakeDebug"
End Sub

Sub test_MakeDebug()
  Debug.Print 1 / 0
End Sub
Sub test_LoopWhenOnTimer()
  Dim i%
  While i < 10
    DoEvents
    Application.Wait Now + TimeSerial(0, 0, 3)
    i = i + 1
    If i = 3 Then Debug.Print 1 / 0
    Debug.Print "  Looping: "; i
  Wend
End Sub

Private Sub callProcTimer(Optional useWinform As Boolean = True)
  Dim h As LongPtr: h = Choose(1, AddressOf ProcTimer)
  Call SetNewTimer(h, cIdEvent, 50, 5000, useWinform, True)
  Call SetNewTimer(h, cIdEvent + 1, 50, 10000, useWinform, True)
  'Debug.Print 1 / 0
  'If Not useWinform Then End
End Sub
Private Sub endProcTimer()
  Dim h As LongPtr
  'killTimer
End Sub
Private Sub ProcTimer(ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal idEvent As LongPtr, ByVal dwTime As LongPtr)
  On Error Resume Next
  Static i%, i2%:
  Dim b As Boolean: b = GetProp(hwnd, CStr(hwnd)) = 0
  If onBreakTimer(hwnd, idEvent, 2) <> 0 Then
    If b Then i = 0 Else i2 = 0
    Exit Sub
  End If
  '-------------------------------------------------------
  ' Code Something
  If b Then
    i = i + 1
    'Debug.Print " Userform: "; idEvent; i, "time: "; Int((dwTime - GetProp(hWnd, "C" & CStr(idEvent))) / 1000), Err, Application.Interactive
  Else
    i2 = i2 + 1: 'If i2 > 5 Then End
    'Debug.Print "NewWindow: "; idEvent; i2, "time: "; Int((dwTime - GetProp(hWnd, "C" & CStr(idEvent))) / 1000), Err, Application.Interactive
  End If
  Debug.Print "IsWindowEnabled: "; IsWindowEnabled(Application.hwnd); i; i2
  '-------------------------------------------------------
  If repeatSetTimer(hwnd, idEvent, dwTime) Then
    ' Code Something

  End If
End Sub

'======================================================================================================================
' Safe-Timer And StateLoss Callback
'======================================================================================================================
'-----------------------------------------------------------
'                  Method: SetNewTimer
'-----------------------------------------------------------
' SetProp Prefix+idEvent:
'   Prefix E: Elapse Timer
'   Prefix T: Time over
'   Prefix X: Main ProcTimer Address
'   Prefix P: Fake ProcTimer Address
'   Prefix C: current time
'   Prefix B: Enabled repeatSetTimer
'   Prefix R: callback If VB Reset (StateLoss Callback)
'   Prefix S: StateLoss
'   Prefix I: idCreateWindow
'-----------------------------------------------------------
Sub SetNewTimer(ByVal ProcAddr As LongPtr, ByVal idEvent As LongPtr, Optional ByVal uElapse As LongPtr, _
        Optional ByVal eElapse As LongPtr, Optional useWinform As Boolean = True, _
        Optional callbackIfVBReset As Boolean, Optional ByVal createWindowByProcAddr As Boolean)
  If idEvent <= 1000 Then Err.Raise 8550001, , "Enter idEvent great than 1000"
  Dim h As LongPtr, p As LongPtr, u As LongPtr, s$, a, b, i%

  p = ProcAddr: ProcAddr = Choose(1, AddressOf virtualProcTimer)
  SwapMemoryAddresses ProcAddr, p

  s = CStr(idEvent): u = uElapse
  h = iiiVirtualWindow(useWinform, 1, , IIf(createWindowByProcAddr, ProcAddr, 0))
  Select Case GetProp(h, "S" & s)
  Case 0: SetProp h, "C" & s, getTickCount
  Case 1: u = u - getTickCount + GetProp(h, "C" & s): If u < 0 Then u = 0
  End Select
  a = Array("P", "X", "E", "T", "B", "I", "S", "R")
  b = Array(ProcAddr, p, uElapse, eElapse, 1, -createWindowByProcAddr, 0, -callbackIfVBReset)
  For i = 0 To UBound(a)
    SetProp h, a(i) & s, b(i)
  Next
  If Not useWinform Then
    Dim l As LongPtr, n As LongPtr, o As LongPtr:  n = h
    Do: l = 0: l = GetProp(h, CStr(n)):
      If l <> 0 Then n = l: If o = 0 Then o = l Else If o = l Then Exit Do
    Loop Until l = 0
    If n <> idEvent Then SetProp h, CStr(n), idEvent ' set multi idEvent
  End If
  h = SetTimer(h, idEvent, u, ProcAddr)
End Sub
Function repeatSetTimer(ByVal hwnd As LongPtr, ByVal idEvent As LongPtr, Optional ByVal dwTime As LongPtr) As Boolean
  On Error Resume Next
  Dim t As LongPtr, s$
  s = CStr(idEvent): t = GetProp(hwnd, "T" & s) + GetProp(hwnd, "C" & s)
  If dwTime <= t And dwTime > 0 And GetProp(hwnd, "B" & s) = 1 Then
    Call SetTimer(hwnd, idEvent, GetProp(hwnd, "E" & s), GetProp(hwnd, "P" & s)): repeatSetTimer = True
  Else
    RemoveAllProp hwnd, idEvent
  End If
End Function
Function stopTimer(ByVal ProcAddr As LongPtr, ByVal idEvent As LongPtr, _
        Optional useWinform As Boolean, Optional ByVal newHandle As Boolean) As Boolean
  On Error Resume Next
  Dim h As LongPtr
  h = iiiVirtualWindow(useWinform, 1, , IIf(newHandle, ProcAddr, 0))
  KillTimer h, idEvent: RemoveAllProp h, idEvent
End Function
Private Sub RemoveAllProp(ByVal hwnd As LongPtr, ByVal idEvent As LongPtr)
  On Error Resume Next
  Dim h As LongPtr, l As LongPtr, n As LongPtr, s$, i
  h = hwnd: s = CStr(idEvent)
  For Each i In Array("P", "X", "E", "T", "B", "R", "C", "S", "I")
    RemoveProp h, i & s
  Next
  n = GetProp(h, CStr(h))
  If n = idEvent Then SetProp h, CStr(h), GetProp(h, s): Exit Sub
  Do: l = GetProp(h, CStr(n)): If l = idEvent Then SetProp h, CStr(n), GetProp(h, s): Exit Do
    If l > 0 Then n = l
  Loop Until l = 0
  RemoveProp h, s
End Sub
Function onBreakTimer(Optional ByVal hwnd As LongPtr, Optional ByVal idEvent As LongPtr, _
            Optional ByVal onBreak&, Optional ByVal onDoEvents As Boolean) As Long
  On Error Resume Next
  KillTimer hwnd, idEvent
  Dim h As LongPtr
l:
  h = FindWindow("#32770", "Microsoft Visual Basic")
  If h = 0 Then
    h = FindWindow("#32770", "Microsoft Visual Basic for Applications")
    If h <> 0 Then onBreakTimer = 1: GoTo c
  Else
    If (onBreak And 1) <> 0 Then onBreakTimer = 2:
    GoTo c
  End If
  Err.Clear
Exit Function
c:
  If (onBreak And 2) <> 0 Then
    Const IDEnd = &H12C0, IDDebug = &H12C1, IDContinue = &H12C2, BM_CLICK = &HF5
    Call SendMessage(GetDlgItem(h, IDEnd), BM_CLICK, 0, ByVal 0)
  End If
End Function
Private Sub virtualProcTimer()
  On Error Resume Next
  Dim h As LongPtr, l As LongPtr, ll As LongPtr, o As LongPtr, s$, k%:
  Dim h0 As LongPtr, p0 As LongPtr, o0 As LongPtr
  h0 = iiiVirtualWindow(0): h = h0: ll = h0
  Do While h > 0
    l = h
    Do:
      l = GetProp(h, CStr(l)): If l = 0 Or o = l Then Exit Do
      KillTimer h, l: s = CStr(l)
      If GetProp(h, "R" & s) = 1 Then
        k = k + 1: SetProp h, "S" & s, 1
        Call SetNewTimer(GetProp(h, "X" & s), l, GetProp(h, "E" & s), GetProp(h, "T" & s), False, True, GetProp(h, "I" & s))
      Else
        RemoveAllProp h, l
      End If
      If o = 0 Then o = l
    Loop Until l = 0
    p0 = GetProp(h0, "VW" & CStr(h))
    If k > 0 Then ll = h Else If h <> h0 Then SetProp h0, "VW" & ll, p0: DestroyWindow h
    h = p0: If h = 0 Or o0 = h Then Exit Do
    If o0 = 0 Then o0 = h
  Loop
End Sub

Sub DestroyAllVirtualWindow()
  On Error Resume Next
  Dim h As LongPtr, h0 As LongPtr, o0 As LongPtr
  h0 = iiiVirtualWindow(0): h = h0
  Do While h > 0
    If h <> h0 Then If IsWindow(h) <> 0 Then DestroyWindow h
    h = GetProp(h0, "VW" & CStr(h)): If h = 0 Or o0 = h Then Exit Do
    If o0 = 0 Then o0 = h
  Loop
  If h0 > 0 Then If IsWindow(h0) <> 0 Then DestroyWindow h0
End Sub

Function iiiVirtualWindow(Optional useWinform As Boolean = True, Optional createnew%, Optional laHwnd As LongPtr, Optional ByVal idCreateWindow As LongPtr) As LongPtr
  If useWinform Then
    ' Use Userform to make handle
    IUnknown_GetWindow ZZZZZUnknownHandleIdEvents, VarPtr(iiiVirtualWindow)
  Else
    ' Use CreateWindow to make handle
    Dim s$, h As LongPtr, h0 As LongPtr
    If idCreateWindow <= 0 Then s = Choose(1, AddressOf virtualProcTimer) Else h0 = iiiVirtualWindow(0, 1, , 0): s = idCreateWindow
    s = "_____XLVirtualWindow[" & s & "]": h = FindWindow("STATIC", s)
    Select Case createnew
    Case 1: If h = 0 Then GoTo n
    Case -1, 2:
      If h > 0 Then DestroyWindow h: h = 0
      If createnew = 2 Then
n:      h = CreateWindowEx(0, "STATIC", s, 0, 0, 0, 0, 0, 0, 0, GetWindowLong(Application.hwnd, (-6)), ByVal 0&)
        If idCreateWindow <> 0 Then
          Dim l As LongPtr, n As LongPtr, o As LongPtr:  n = h0
          Do: l = 0: l = GetProp(h0, "VW" & CStr(n)):
            If l <> 0 Then n = l: If o = 0 Then o = l Else If o = l Then Exit Do
          Loop Until l = 0
          If n <> h Then SetProp h0, "VW" & CStr(n), h ' set multiHandle
        End If
      End If
    End Select
    iiiVirtualWindow = h
  End If
End Function
Private Function iiiVBEHandle() As LongPtr
  Static l As LongPtr
  If l = 0 Then EnumThreadWindows GetCurrentThreadId, AddressOf EnumThreadWndProc, l
  iiiVBEHandle = l
End Function
Private Function EnumThreadWndProc(ByVal hwnd As Long, lParam As LongPtr) As Long
  Dim l1 As Long, h As LongPtr, s1 As String * 100, s$
  l1 = GetClassName(hwnd, s1, 100): s = Left$(s1, l1)
  Select Case s
  Case "wndclass_desked_gsk": lParam = hwnd
  End Select
  EnumThreadWndProc = True
End Function

Private Function SwapMemoryAddresses(ByVal Addrss1 As LongPtr, ByVal Addrss2 As LongPtr)
  Call CopyMemory(ByVal Addrss1 + PTR_LEN * 6& + 4&, ByVal Addrss2 + PTR_LEN * 6& + 4&, PTR_LEN)
End Function
cristianbuse commented 2 months ago

@SanbiVN

This line of code calls DoEvents immediately, causing the event to be closed immediately, so the problem you describe is unlikely.

Sometimes state is lost while running a UDF, especially when a workbook is opened. If this leaves the application in an unwanted state (e.g. hooked DoEvents) then it's a problem. You are correct, it's unlikely, but can happen - so I rather not use it.

Jaafar created a virtual callback function, and swapped memory with the main function.

The swapping is only done to fix the stack parameters on x64. I know because I was the one that implemented this and explained to Jaafar here. I am glad he is succesfully using the workaround.

However, like I said, timers are still my second option because it's still not crash proof even with the fixed stack. Pressing Stop in the IDE or running End while within the scope of the timer callback still leads to a crash and the only way to fix that is to have an assembly trampoline method. My PostMessage approach is 100% crash free so I like this even though in my testing it's 2x-5x slower than timers.

Thanks for all the info!

SanbiVN commented 2 months ago

@cristianbuse

Your method, once when I tested with 40k expressions, Excel on my computer crashed automatically. I only opened your file. I typed another UDF into the cell with Volatile as true. In my Excel there is an Add-in running, containing code to catch the WorksheetChange event.

The code above I built myself, I just saw Jaafar doing memory swap with virtual function

I have a pretty bold project idea, you can listen to my presentation. I am doing VBA code parsing and analysis to achieve the following goals:

  1. Merge code from different projects into a complete project.
  2. Split code in a large source code into separate classes to save interpretation costs.
  3. Automatically search and fix Win32 API references compatible with x32 and x64.

Because, I used to spend a lot of time copying codes from different projects into new projects. I spent a lot of time debugging and fixing bugs. So I want to build this project. I have successfully built the project to the stage of separating each syntax in VBA code. Now it is time to parse. There is a lot of work to do. I have to spend more time to complete it.

If you have time, I'll create a new Github repository for the project for you to check out.

Mo-Gul commented 2 months ago

@SanbiVN, I am not sure if I have understood your project correct, but "parsing of VBA code" sounds like something that is/will be done in https://github.com/rubberduck-vba/Rubberduck or https://github.com/rubberduck-vba/Rubberduck3 respectively as well. Do you know it?

cristianbuse commented 2 months ago

@SanbiVN

I tested the current PostMessage approach a lot and I was never able to crash the app. Can you please provide me with a list of steps so that I can replicate the crash? Thanks!

Regarding your parsing project, I am afraid I won'd have time to get involved at least not for the next 4-6 months. Hopefully it all goes to plan. Thanks!

SanbiVN commented 2 months ago

@cristianbuse I will try a few more times to see what happens.

@Mo-Gul Yes. I am doing this like Rubberduck. But I choose to do it with just VBA code. And target my own goals as I mentioned.

cristianbuse commented 2 months ago

@SanbiVN

Just occured to me. Do you use the ForceVBALoadFromSource hotfix? Sometimes, when you open a project that was saved in a previous app version, you get a crash because the app fails to recompile.

All you need to do is to add a registry entry. For example, for Excel: "Computer\HKEY_CURRENT_USER\Software\Microsoft\Office\" & Application.Version & "\Excel\Options\" you add a key called ForceVBALoadFromSource with a DWORD value of 1.

For more info read this and this

SanbiVN commented 2 months ago

@cristianbuse

The first time I heard this from you, I have projects with a lot of VBA code, many times I crashed Excel as soon as I opened the file. The file was corrupted and could not be opened again. I was forced to choose a backup copy of the file to start over.

I added the key to the registry, time will tell if the problem continues.

cristianbuse commented 2 months ago

@SanbiVN

I added the key to the registry, time will tell if the problem continues.

I've been using this over 6 months now and I had zero crashes since. I'm reffering to crashes when opening the documents.