AW: Timer-Funktion zum Schließen einer Excel-Datei
06.01.2020 19:28:04
Nepumuk
Hallo,
jetzt hab ich doch noch eine nicht angepasste Prozedur gefunden. Der neue Code für die Klasse clsTimer:
Option Explicit
Private Declare PtrSafe Function SetTimer Lib "user32.dll" ( _
ByVal hwnd As LongPtr, _
ByVal nIDEvent As LongPtr, _
ByVal uElapse As Long, _
ByVal lpTimerFunc As LongPtr) As LongPtr
Private Declare PtrSafe Function KillTimer Lib "user32.dll" ( _
ByVal hwnd As LongPtr, _
ByVal nIDEvent As LongPtr) As Long
Private Declare PtrSafe Sub RtlMoveMemory Lib "kernel32.dll" ( _
ByRef Destination As Any, _
ByRef Source As Any, _
ByVal Length As LongPtr)
Private Declare PtrSafe Function VirtualAlloc Lib "kernel32.dll" ( _
ByRef lpAddress As Any, _
ByVal dwSize As LongPtr, _
ByVal flAllocationType As Long, _
ByVal flProtect As Long) As LongPtr
Private Declare PtrSafe Function VirtualFree Lib "kernel32.dll" ( _
ByRef lpAddress As Any, _
ByVal dwSize As LongPtr, _
ByVal dwFreeType As Long) As Long
Private Const MEM_COMMIT As Long = &H1000&
Private Const MEM_DECOMMIT As Long = &H4000&
Private Const PAGE_EXECUTE As Long = &H10&
Private Const PAGE_EXECUTE_READ As Long = &H20&
Private Const PAGE_EXECUTE_READWRITE As Long = &H40&
Private Const ASM_SIZE As LongPtr = &HFF&
Private m_ptrCallback As LongPtr
Private m_hdlTimer As LongPtr
Private m_blnEnabled As Boolean
Private m_lngInterval As Long
Public Event Tick()
Public Sub TimerCallback(ByVal hwnd As LongPtr, ByVal uMsg As Long, _
ByVal idEvent As LongPtr, ByVal dwTime As Long)
RaiseEvent Tick
End Sub
Public Property Get Enabled() As Boolean
Enabled = m_blnEnabled
End Property
Public Property Let Enabled(ByVal blnValue As Boolean)
If blnValue <> m_blnEnabled Then
If blnValue Then
m_hdlTimer = SetTimer(0, 0, Interval, m_ptrCallback)
Else
Call KillTimer(0, m_hdlTimer)
End If
m_blnEnabled = blnValue
End If
End Property
Public Property Get Interval() As Long
Interval = m_lngInterval
End Property
Public Property Let Interval(ByVal lngMs As Long)
m_lngInterval = lngMs
If Enabled Then
Enabled = False
Enabled = True
End If
End Property
Private Function GetFirstPublicMethod(ByVal obj As Object) As LongPtr
Dim pObj As LongPtr
Dim pVtbl As LongPtr
Call RtlMoveMemory(pObj, ByVal ObjPtr(obj), 4)
Call RtlMoveMemory(pVtbl, ByVal pObj + &H1C, 4)
GetFirstPublicMethod = pVtbl
End Function
Private Sub FreeCallback(ByVal ptr As LongPtr)
Call VirtualFree(ByVal ptr, ASM_SIZE, MEM_DECOMMIT)
End Sub
Private Function CreateCallback(ByVal obj As Object, _
ByVal addr As LongPtr, ByVal params As Long) As LongPtr
Dim ptrMem As LongPtr
Dim ptrItr As LongPtr
Dim ptrNewAddr As LongPtr
Dim i As Long
ptrMem = VirtualAlloc(ByVal 0&, ASM_SIZE, MEM_COMMIT, PAGE_EXECUTE_READWRITE)
If ptrMem = 0 Then
Call Err.Raise(vbObjectError, , "VirtualAlloc fehlgeschlagen!")
End If
ptrItr = ptrMem
For i = 1 To params
Call RtlMoveMemory(ByVal ptrItr + 0, &H2474FF, 3)
Call RtlMoveMemory(ByVal ptrItr + 3, params * 4, 1)
ptrItr = ptrItr + 4
Next
Call RtlMoveMemory(ByVal ptrItr + 0, &H68, 1)
Call RtlMoveMemory(ByVal ptrItr + 1, ObjPtr(obj), 4)
ptrItr = ptrItr + 5
ptrNewAddr = addr - ptrItr - 5
Call RtlMoveMemory(ByVal ptrItr + 0, &HE8, 1)
Call RtlMoveMemory(ByVal ptrItr + 1, ptrNewAddr, 4)
ptrItr = ptrItr + 5
Call RtlMoveMemory(ByVal ptrItr + 0, &HC2, 1)
Call RtlMoveMemory(ByVal ptrItr + 1, params * 4, 2)
CreateCallback = ptrMem
End Function
Private Sub Class_Initialize()
m_ptrCallback = CreateCallback(Me, GetFirstPublicMethod(Me), 4)
End Sub
Private Sub Class_Terminate()
If Enabled Then Enabled = False
Call FreeCallback(m_ptrCallback)
End Sub
Gruß
Nepumuk