Private Const ProjectName = "VBSafeTimerStateLoss"
Private Const ProjectVersion = "1.1"
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
#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 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 GetCurrentThreadId Lib "kernel32" () As Long
Private Declare PtrSafe Function IsWindow Lib "user32" (ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) 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 PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) 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 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 GetCurrentThreadId Lib "kernel32" () As Long
Private Declare Function IsWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As LongPtr
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 PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
#End If
Private Enum idEventUseDefined
cIdEvent = 111122000
End Enum
'======================================================================================================================
' Safe-Timer And StateLoss Callback
'======================================================================================================================
'-----------------------------------------------------------
' Method: setSafeTimer
'-----------------------------------------------------------
' 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 setSafeTimer(ByVal idEvent As LongPtr, ByVal ProcAddr As LongPtr, Optional ByVal virtualProc As LongPtr, _
Optional ByVal uElapse As LongPtr, _
Optional ByVal eElapse As LongPtr, _
Optional callbackIfVBReset As Boolean, Optional ByVal newHandle As Boolean, Optional ByVal hwnd As LongPtr)
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%
#If Win64 Then
p = ProcAddr: ProcAddr = virtualProc
If ProcAddr = 0 Then ProcAddr = Choose(1, AddressOf virtualProcTimer)
SwapMemoryAddresses ProcAddr, p
#End If
s = CStr(idEvent): u = uElapse
h = hwnd: If h = 0 Then h = iiiVirtualWindow(1, IIf(newHandle, 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, -newHandle, 0, -callbackIfVBReset)
For i = 0 To UBound(a)
SetProp h, a(i) & s, b(i)
Next
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
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
Dim t As LongPtr, l As LongPtr, s$
s = CStr(idEvent): l = GetProp(hwnd, "T" & s): t = l + GetProp(hwnd, "C" & s)
If (dwTime <= t And dwTime > 0 And GetProp(hwnd, "B" & s) = 1) Or l < 0 Then
Call SetTimer(hwnd, idEvent, GetProp(hwnd, "E" & s), GetProp(hwnd, "P" & s)): repeatSetTimer = True
Else
RemoveAllProp hwnd, idEvent
End If
End Function
Function killSafeTimer(ByVal ProcAddr As LongPtr, ByVal idEvent As LongPtr, Optional ByVal newHandle As Boolean) As Boolean
On Error Resume Next
Dim h As LongPtr
h = iiiVirtualWindow(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
If onBreak <> 0 Then
Dim h As LongPtr
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
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(): 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 setSafeTimer(l, GetProp(h, "X" & s), GetProp(h, "P" & s), GetProp(h, "E" & s), GetProp(h, "T" & s), 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: CloseWindow 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(): h = h0
Do While h > 0
If h <> h0 Then If IsWindow(h) <> 0 Then CloseWindow 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 CloseWindow h0
End Sub
Function iiiVirtualWindow(Optional createnew%, Optional ByVal idCreateWindow As LongPtr) As LongPtr
' 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(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 CloseWindow h: h = 0
If createnew = 2 Then
n: h = CreateWindowEx(0, "STATIC", s, 0, 0, 0, 0, 0, 0, 0, GetModuleHandle(vbNullString), 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 Function
Function iiiVBEHandle() As LongPtr
Static l As LongPtr
If l = 0 Then EnumThreadWindows GetCurrentThreadId, AddressOf EnumThreadWndProc, l
If l = 0 Then l = Application.hwnd Else If IsWindow(l) = 0 Then l = Application.hwnd
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
Sub CloseWindow(hwnd As LongPtr)
Const WM_CLOSE = &H10
Const WM_QUIT = &H12
Const WM_DESTROY = &H2
Const WM_NCDESTROY = &H82
PostMessage hwnd, WM_CLOSE, 0, 0
'PostMessage Hwnd, WM_DESTROY, 0, 0
' PostMessage Hwnd, WM_NCDESTROY, 0, 0
' PostMessage Hwnd, WM_QUIT, 0, 0
End Sub
