Emailadresse auf Vollständigkeit prüfen

Public Function IsValidEMail(S)
Dim Ch As String * 1, i As Long, Ats As Long, Periods As Long
Dim LeftofAt As Boolean, IsLeading As Boolean
IsValidEMail = True
If IsNull(S) Then Exit Function
IsValidEMail = False
LeftofAt = True
IsLeading = True
Periods = 0
Ats = 0
For i = 1 To Len(S)
Select Case Asc(Mid(S, i, 1))
Case Asc("@")
Ats = Ats + 1
' links vom "@" muss wenigstens ein Zeichen sein:
If i = 1 Then Exit Function
' nur ein "@" erlaubt:
If Ats > 1 Then Exit Function
LeftofAt = False
IsLeading = True
Case Asc(".")
' Punkte rechts vom "@" zählen:
If Not LeftofAt Then Periods = Periods + 1
' zu viele Punkte (technisch zwar möglich, aber unwahrscheinlich):
If Periods > 4 Then Exit Function
' Top Level Domain hat weniger als 2 Zeichen:
If i > Len(S) - 2 Then Exit Function
Case Asc("A") To Asc("Z"), Asc("a") To Asc("z"), Asc("0") To Asc("9")
IsLeading = False
Case Asc("-")
' kein führendes "-" erlaubt:
If IsLeading Then Exit Function
Case Asc("_")
' "_" nur links vom "@" erlaubt:
If IsLeading Or Not LeftofAt Then Exit Function
Case Else
' andere Zeichen sind nicht zulässig:
Exit Function
End Select
Next
If Periods > 0 Then IsValidEMail = True
End Function

Public Sub CommandButton1_Click()
If Dir("H:\Subkontraktoren-Anlage", vbDirectory) = "" Then
MkDir "H:\Subkontraktoren-Anlage"
Else
ChDir ("H:\Subkontraktoren-Anlage")
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
"H:\Subkontraktoren-Anlage\Subkontraktoren-Anlage.pdf", openAfterPublish:=False
Dim Outlook As Object
Dim OutlookMailItem As Object
Dim myAttachments As Object
Set Outlookapp = CreateObject("outlook.application")
Set OutlookMailItem = Outlookapp.CreateItem(0)
Set myAttachments = OutlookMailItem.Attachments
On Error Resume Next
With OutlookMailItem
.To = Me.TextBox1.Value
.Cc = Me.TextBox2.Value
.Subject = Me.TextBox3.Value
.Body = Me.TextBox4.Value
myAttachments.Add "H:\Subkontraktoren-Anlage\Subkontraktoren-Anlage.pdf" _
.Send
End With
Call CommandButton2_Click
End If
End Sub