Option Explicit
Private Sub CommandButton1_Click()
Dim olApp As Outlook.Application
Dim olMail As Outlook.MailItem
Dim olRun As Boolean
Dim strEmailAdr As String
Dim Start As Single
Dim lngLetzteZeile As Long
Dim lngLaufZahl As Long
On Error Resume Next
With ThisWorkbook
With .Sheets(1)
lngLetzteZeile = .Cells(.Cells.Rows.Count, "A").End(xlUp).Row
olRun = True
Set olApp = GetObject(, "Outlook.Application")
If Err.Number <> 0 Then
Err.Clear
Set olApp = CreateObject("Outlook.Application"): DoEvents
Start = Timer
While Timer < Start + 5
DoEvents
Wend
olRun = False
End If
For lngLaufZahl = 5 To lngLetzteZeile
If UCase(.Cells(lngLaufZahl, "D")) = "X" And .Cells(lngLaufZahl, "C") <> "" Then
strEmailAdr = .Cells(lngLaufZahl, "C")
If InStr(1, strEmailAdr, "@", vbBinaryCompare) = 0 Or InStr(1, strEmailAdr, ".", vbBinaryCompare) = 0 Then
MsgBox "Wegen fehlender oder unkorrekter Emailadresse kann an " & .Cells(lngLaufZahl, "A") & ", " & .Cells(lngLaufZahl, "B") & " keine Antwortmail versandt werden!", vbCritical, "Abbruch..."
GoTo Weiter
End If
Set olMail = olApp.CreateItem(0)
With olMail
.Recipients.Add strEmailAdr
.Subject = "Hier Deinen Betreff einfügen"
.body = "Hier Deinen Text einfügen" & Chr(10) & "Dies ist ein automatisch versandte Email! Bitte nicht beantworten!"
.send
End With
Set olMail = Nothing
End If
Weiter:
Next lngLaufZahl
If olRun = False Then
olApp.Quit: DoEvents
Start = Timer
While Timer < Start + 2
DoEvents
Wend
End If
End With
End With
Set olApp = Nothing
End Sub