AW: Mail aus Excel heraus automatisch versenden
18.06.2007 16:03:00
Renee
Mazwara René,
Das wird komplizierter. Folgender Code testet/sendet Mails 1 mal pro Stunde.
Kopiere den Code, wie dokumentiert (lösche vorher den alten Code), also oberer Teil in DieseArbeitsmappe und unterer Teil in ein Modul
' This code belongs to ThisWorkbook
' Press Alt-F11
' Select ThisWorkbook from the project-explorer
' and copy the code below into the empty window
Option Explicit
Private Sub Workbook_BeforeClose(Cancel As Boolean)
stopWatch
End Sub
Private Sub Workbook_Open()
dNextRun = Now()
checkAlert
End Sub
' This code belongs to a module
' Press Alt-F11
' Rightclick on the project in the project-explorer
' Select Insert Module and copy the code below into the empty window
Option Explicit
Public dNextRun As Double
Sub stopWatch()
On Error Resume Next
Application.OnTime dNextRun, "watchAlert", schedule:=False
dNextRun = 0
End Sub
Sub watchAlert()
If dNextRun = 0 Then Exit Sub
dNextRun = Now + TimeSerial(1, 0, 0)
Call checkAlert
Application.OnTime dNextRun, "watchAlert", schedule:=True
End Sub
Sub checkAlert()
Dim rCell As Range
Dim objApp As Object
Dim objMailItm As Object
Dim tBRng As String
Dim tReceiver As String
tBRng = "A11:A" & Sheets("ToDo").UsedRange.Rows.Count
tReceiver = Sheets("ToDo").Range("B4")
Set objApp = CreateObject("Outlook.Application")
For Each rCell In Sheets("ToDo").Range(tBRng)
If IsDate(rCell.Offset(0, 5).Value) Then
If rCell.Offset(0, 5) - Date " & vbCrLf & _
"wird am " & rCell.Offset(0, 5).Value & " fällig!"
.Send
End With
rCell.Offset(0, 9).Value = True
Set objMailItm = Nothing
End If
End If
Next
Set objApp = Nothing
End Sub
Zum testen, kannst du diese Zeile:
dNextRun = Now + TimeSerial(1, 0, 0)
ersetzen durch:
dNextRun = Now + TimeSerial(0, 1, 0)
Damit wird jede Minute getestet, statt jede Stunde.
Greetz Renee