Achte darauf, wo welche Code-Teile hingehören und dass das Klassenmodul den richtigen Name erhält.
' **********************************************************************
' Modul: DieseArbeitsmappe Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************
Option Explicit
Private Sub Workbook_Open()
Call Tabelle1.StopTimer
End Sub
' **********************************************************************
' Modul: Tabelle1 Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************
Option Explicit
Private WithEvents Timer1 As APITimer
Private dblTime As Double
Private Sub Worksheet_Calculate()
If Not Timer1 Is Nothing Then
If Timer1.Enabled Then
If Range("I2") = 10 Then StopTimer
End If
End If
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address(0, 0) = "I1" Then
If Timer1 Is Nothing Then
Set Timer1 = New APITimer
End If
With Timer1
If Not .Enabled Then
Range("J10") = ""
dblTime = Timer
.IntervalMS = 100
.Enabled = True
End If
End With
End If
End Sub
Private Sub Timer1_Tick()
On Error Resume Next
Application.EnableEvents = False
Range("J10") = (Timer - dblTime) / 86400
Application.EnableEvents = True
End Sub
Public Sub StopTimer()
On Error Resume Next
Timer1.Enabled = False
End Sub
' **********************************************************************
' Modul: APITimer Typ: Klassenmodul
' **********************************************************************
Option Explicit
' benötigte API-Deklarationen
Private Declare Function SetTimer Lib "user32" ( _
ByVal hWnd As Long, _
ByVal nIdEvent As Long, _
ByVal uElapse As Long, _
ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32" ( _
ByVal hWnd As Long, _
ByVal uIDEvent As Long) As Long
Private Declare Sub CopyMem Lib "kernel32" _
Alias "RtlMoveMemory" ( _
pDst As Any, _
pSrc As Any, _
ByVal cb As Long)
Private Declare Function VirtualAlloc Lib "kernel32" ( _
lpAddress As Any, _
ByVal dwSize As Long, _
ByVal flAllocationType As Long, _
ByVal flProtect As Long) As Long
Private Const MEM_COMMIT As Long = &H1000&
Private Declare Function VirtualFree Lib "kernel32" ( _
lpAddress As Any, _
ByVal dwSize As Long, _
ByVal dwFreeType As Long) As Long
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 Long = &HFF&
Private m_ptrCallback As Long
Private m_hdlTimer As Long
Private m_blnEnabled As Boolean
Private m_lngInterval As Long
Public Event Tick()
' muss erste öffentliche Methode in Interface sein!
' API Timer wird diese Methode aufrufen
Public Sub TimerCallback( _
ByVal hWnd As Long, ByVal uMsg As Long, _
ByVal idEvent As Long, ByVal dwTime As Long)
RaiseEvent Tick
End Sub
' Aktiviert/Deaktiviert Timer (vgl. VB Intrinsic)
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, IntervalMS, m_ptrCallback)
Else
KillTimer 0, m_hdlTimer
End If
m_blnEnabled = blnValue
End If
End Property
' Bestimmt Interval, in dem Tick Event gefeuert wird
' (in Millisekunden)
Public Property Get IntervalMS() As Long
IntervalMS = m_lngInterval
End Property
Public Property Let IntervalMS(ByVal lngMs As Long)
m_lngInterval = lngMs
If Enabled Then
' wird Interval geändert während Timer aktiv ist,
' muss er neu initialisiert werden
Enabled = False
Enabled = True
End If
End Property
' Adresse erster öffentlicher Methode eines COM Interfaces ermitteln
Private Function GetFirstPublicMethod(ByVal obj As Object) As Long
Dim pObj As Long
Dim pVtbl As Long
' Adresse über VTable des Interfaces (IUnknown und IDispatch
' dort zuerst eingetragen, daher 7 Einträge = &H1C Bytes überspringen)
CopyMem pObj, ByVal ObjPtr(obj), 4
CopyMem pVtbl, ByVal pObj + &H1C, 4
GetFirstPublicMethod = pVtbl
End Function
' Für ASM Callback genutzten Speicher freigeben
Private Sub FreeCallback(ByVal ptr As Long)
VirtualFree ByVal ptr, ASM_SIZE, MEM_DECOMMIT
End Sub
' ASM Callback erstellen, das Timercallbacks an eine
' Methode der Klasse weiterleitet
Private Function CreateCallback(ByVal obj As Object, _
ByVal addr As Long, ByVal params As Long) As Long
Dim ptrMem As Long
Dim ptrItr As Long
Dim ptrNewAddr As Long
Dim i As Long
Dim j As Long
' ausführbaren Speicher vom System holen
' und Maschinencode reinschreiben
ptrMem = VirtualAlloc(ByVal 0&, ASM_SIZE, MEM_COMMIT, PAGE_EXECUTE_READWRITE)
If ptrMem = 0 Then
Err.Raise 12345, , "VirtualAlloc fehlgeschlagen!"
End If
ptrItr = ptrMem
For i = 1 To params
CopyMem ByVal ptrItr + 0, &H2474FF, 3 ' PUSH [ESP+imm8]
CopyMem ByVal ptrItr + 3, params * 4, 1
ptrItr = ptrItr + 4
Next
CopyMem ByVal ptrItr + 0, &H68, 1 ' PUSH imm32
CopyMem ByVal ptrItr + 1, ObjPtr(obj), 4
ptrItr = ptrItr + 5
ptrNewAddr = addr - ptrItr - 5
CopyMem ByVal ptrItr + 0, &HE8, 1 ' CALL rel32
CopyMem ByVal ptrItr + 1, ptrNewAddr, 4
ptrItr = ptrItr + 5
CopyMem ByVal ptrItr + 0, &HC2, 1 ' RET imm16
CopyMem 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
FreeCallback m_ptrCallback
End Sub