ich versuche seit Stunde eine aus dem Netz gefundene Funktion in meine Tabelle einzubauen. Es handelt sich um eine Funktion zur Prüfung der Emailadresse (Syntaxprüfung)
Hier der Code:
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
Ich habe im weiteren eine Userform mit zwei Textfeldern für Emailadressen und zwei CommandButtons (Absenden und Abbruch)Hier der Code in der Userform
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
Wie kann ich die Private Function zur Syntaxabfrage in den Commandbutton1 (Absenden) einbringen (ich habe keinen Plan von functions...)Schon einmal vielen Dank für die Unterstützung!
VG Gregy