AW: Outlook MAkro nach Zeit starten
03.02.2010 21:10:32
Josef
Hallo Anette,
hab die mal was gebalstelt, vielleicht hilft es dir.
Die Klassenmodule musst du wie im angehängten Code benennen, als 1x APITimer und 1x clsInit.
' **********************************************************************
' Modul: ThisOutlookSession
' **********************************************************************
Option Explicit
Private Sub Application_Startup()
initTimer
End Sub
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Public newTimer As clsInit
Public Sub initTimer()
Set newTimer = New clsInit
newTimer.create
newTimer.Timer1.IntervalMS = 10000 'alle 10 Sekunden wird gecheckt!
newTimer.Timer1.Enabled = True
End Sub
Public Sub deinMakro()
MsgBox "Hallo"
End Sub
' **********************************************************************
' Modul: clsInit Typ: Klassenmodul
' **********************************************************************
Option Explicit
Public WithEvents Timer1 As APITimer
Private bAction As Boolean
Public Sub create()
Set Timer1 = New APITimer
bAction = True
End Sub
Private Sub Class_Terminate()
Me.Timer1.Enabled = False
End Sub
Private Sub Timer1_Tick()
'zu jeder vollen Stunde
'If bAction Then
' If Minute(Now) = 0 Then
' bAction = False
' Call deinMakro
' Else
' bAction = True
' End If
'End If
'zu bestimmter Uhrzeit, Beispiel 09:45
If bAction Then
If TimeSerial(Hour(Now), Minute(Now), 0) = TimeSerial(9, 45, 0) Then
bAction = False
Call deinMakro
Else
bAction = True
End If
End If
End Sub
' **********************************************************************
' Modul: APITimer Typ: Klassenmodul
' **********************************************************************
'Code der Klasse "APITimer"
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
Gruß Sepp