e-mail automatisch versenden bei Bedingung
26.09.2006 15:51:38
frank
ich habe im Forum ein tolles makro gefunden welches mir bei meinem Problem sehr helfen könnte. Dieses schaut in C4 und weiter mit E4, F4... -> habe es mal so gelassen wegen den Urheberrechten!!
Ich brauche nun Hilfe um dieses etwas umzustricken. Habe von VBA außer Makrorecorder noch nicht viel Ahnung. Es sind mehr oder weniger Wenn abfragen.
Ich habe eine Tabelle welche Zeilenweise abgearbeitet werden soll.
Ich probiere mal dies zu veranschaulichen.
Das Programm soll folgendes machen:
Es soll Zeile für Zeile durchgegangen und nur eine mail abgeschickt werden wenn folgende Bedingungen erfüllt sind. Beginn in Zeile 1:
Wenn in Zelle F1 ein x steht und L1 leer ist und das heutige datum plus 7 Tage kleiner oder gleich dem datum in K1 dann Kopiere email Adresse von Zelle J1 nach L1 und sende eine mail an die Adresse welche in Zelle J1 steht.
Ich hoffe mir kann jemand auf die Sprünge helfen.
Gruß Frank
Sub Mail()
Dim objOutlook As Outlook.Application
Dim objOutlookMsg As Outlook.MailItem
Dim objOutlookRecip As Outlook.Recipient
Dim strFile As String, strRecipient As String, strSubject As String
Dim bolStatusBar
bolStatusBar = Application.DisplayStatusBar
Range("C4").Select
Do While ActiveCell <> ""
If ActiveCell > 0 Then
ActiveCell.Offset(-2, 0) = ""
End If
If ActiveCell <= 0 And ActiveCell.Offset(-2, 0) = "" Then
ActiveCell.Offset(-2, 0) = "ja"
' betrag = Format(ActiveCell, "0.00")' brauche ich nicht
Set objOutlook = CreateObject("Outlook.Application")
strRecipient = ActiveCell.Offset(-3, 0)
strSubject = "Erinnerung!"
Set objOutlookMsg = objOutlook.CreateItem(olMailItem)
With objOutlookMsg
Set objOutlookRecip = .Recipients.Add(strRecipient)
objOutlookRecip.Type = olTo
.Subject = strSubject
.Body = "Hallo, " & vbLf & vbLf & _
"Denkt bitte an ... " & vbLf & vbLf & vbLf & _
"Mit freundlichen Grüßen" & vbLf & vbLf & vbLf & _
Application.UserName
weiter:
objOutlookRecip.Resolve
End With
Set objOutlook = Nothing
'objOutlookMsg.Display ' wird jede Mail vorher angeigt
objOutlookMsg.Send ' wird jede Mail gleich abgeschickt
Application.StatusBar = False
Application.DisplayStatusBar = bolStatusBar
End If
ActiveCell.Offset(0, 1).Select
Loop
End Sub