AW: Code ausführen wenn Application gewechselt wird
04.01.2011 15:33:51
Josef
Hallo Marco,
probier mal folgenden Code.
' **********************************************************************
' Modul: DieseArbeitsmappe Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************
Option Explicit
Private WithEvents Timer1 As APITimer
Private Declare Function GetActiveWindow Lib "user32" () As Long
Private Declare Function FindWindowA Lib "user32" (ByVal lpClassName As String, ByVal lpWindowName _
As String) As Long
Private Sub Timer1_Tick()
Dim acthWnd As Long, UFhWnd As Long
On Error Resume Next
If UserForm1.Visible Then
UFhWnd = GetFormHandle(UserForm1)
acthWnd = GetActiveWindow
If acthWnd <> UFhWnd Then
Unload UserForm1
End If
End If
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
stopTimer
End Sub
Private Sub Workbook_Open()
runTimer
End Sub
Sub runTimer()
Set Timer1 = New APITimer
Timer1.IntervalMS = 500
Timer1.Enabled = True
End Sub
Private Sub stopTimer()
On Error Resume Next
Timer1.Enabled = False
Set Timer1 = Nothing
End Sub
Private Function GetFormHandle(ByVal frmName As msForms.UserForm, Optional bByClass As Boolean = _
True) As Long
'returns a handle to the userform
Dim strClassName As String
Dim strCaption As String
strClassName = IIf(Val(Application.Version) > 8, "ThunderDFrame", _
"ThunderXFrame") & vbNullChar
strCaption = vbNullString
GetFormHandle = FindWindowA(strClassName, strCaption)
End Function
' **********************************************************************
' Modul: APITimer Typ: Klassenmodul
' **********************************************************************
Option Explicit
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
Gruß Sepp