AW: Private Const CheckCell_1 = "System!AI9"
05.08.2008 19:25:30
Susanne
Oh je, dachte, ich hätte das Entscheidende der Übersichlichkeit halber herauskopiert.
Hier das ganze Modul:
Option Explicit
' define which cell to be monitored
Private Const CheckCell_1 = "System!AI9"
'define checking interval;
' (new pop-up time is added to this automatically, CheckInterv has to be greater than the 10sec pop-up)
Private Const CheckInterv = "00:05:20" ' special format "hh:mm:ss": 00:00:03 means 3 seconds
'define end time for checking
Private Const TimeCheck = "17:32:00" ' special format "hh:mm:ss"
'define target email address
Private Const TargetEmail = "susanne123@googlemail.com"
'define alarm sound wav file
Private Const AlarmSoundFile = "C:\ringin.wav"
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' first draft version
' one cell is checked each interval, send email if cell not changed (simple check with last value)
'
' modified with check end time
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' no user definitions below these lines
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' sound play
Declare Function sndPlaySound32 Lib "winmm.dll" _
Alias "sndPlaySoundA" (ByVal lpszSoundName _
As String, ByVal uFlags As Long) As Long
' new variables for sound and auto-close pop-up
Dim WshShell
Dim intText As Integer
Dim EmailSubject As String
Dim iTimerSet As Double
Private Sub Workbook_BeforeClose(Cancel As Boolean)
KillAlarmHandler
End Sub
Public Sub AlarmHandler()
' following commands are executed each interval
If Cell_1HasChanged Then
' just for debug
' EmailSubject = "no alarm"
' MailSenden
Else
EmailSubject = Format(Now, "hh:nn:ss") + " alarm alert; value (" & CheckCell_1 & ") = " _
& Range(CheckCell_1).Value
' sound and pop-up
' Call sndPlaySound32("C:\tmp\doorbell.wav", 1)
Call sndPlaySound32(AlarmSoundFile, 1)
'Set WshShell = CreateObject("WScript.Shell")
'intText = WshShell.Popup(EmailSubject, 19, "Alarm")
MailSenden
End If
iTimerSet = Now + TimeValue(CheckInterv) ' increment timer to next interval
If Format(Now, "hh:nn:ss")
Public Sub KillAlarmHandler()
On Error Resume Next
Application.OnTime iTimerSet, "AlarmHandler", , False
End Sub
Private Sub MailSenden()
Dim MyOutApp As Object, MyMessage As Object
Set MyOutApp = CreateObject("Outlook.Application")
Set MyMessage = MyOutApp.CreateItem(0)
With MyMessage
.to = TargetEmail ' "Hier kommt die Adresse rein"
'"hier der Betreff"
.Subject = EmailSubject
' email body
.body = "value of cell (" & CheckCell_1 & ") = " & Range(CheckCell_1).Value
'.Attachments.Add 'für Anlagen
.Importance = 2 'Wichtigkeit hoch
.Display
.Send 'Hier wird die Mail gesendet
End With
Set MyOutApp = Nothing
Set MyMessage = Nothing
End Sub
Private Function Cell_1HasChanged() As Boolean
Static vLastStored As Variant
If Range(CheckCell_1).Value = vLastStored Then
Cell_1HasChanged = False
Else
Cell_1HasChanged = True
End If
vLastStored = Range(CheckCell_1).Value
End Function
'