' ServerName: Name des SMTP-Servers
' bei T-Online z.B. mailto.btx.dtag.de
'
' EmpfName: Name des Empfängers
' EmpfEMail: EMail-Adresse des Empfängers
' AbsName: Absender-Name (Ihr Name)
' AbsEMail: Absender-EMail (Ihre EMail-Adresse)
' Betreff: Nachrichten-Betreff (Subject)
' Nachricht: Nachrichten-Text
'======================================================
Public Function MailSend(ServerName As String, EmpfName As _
String, EmpfEMail As String, AbsName As String, _
AbsEMail As String, Betreff As String, _
ByVal Nachricht As String) As Boolean
Dim Header As String
Dim iPos As Long
Const CR = vbNewLine
-> Status-Fenster leeren
frmStatus.txtStatus.Text =
If Not frmStatus.Visible Then frmStatus.Show , Me
With Winsock1
-> Anmelden am Mailserver
lblStatus.Caption = Verbinden mit: + _
ServerName + ...
.Protocol = sckTCPProtocol
.LocalPort = 0
.Connect ServerName, 25
-> Warten, bis die Verbindung hergestellt ist
Do While .State < sckConnected
DoEvents
Loop
-> Keine Verbindung möglich?
If .State > sckConnected Then
MsgBox Kein Verbindungsaufbau möglich!
MailSend = False
Else
-> HELO schicken (Begrüssung)
lblStatus.Caption = Anmelden am Server...
.SendData HELO & ServerName & CR
If Not WaitForResponse(250) Then GoTo Send_End
-> Absender-Daten
lblStatus.Caption = Sende Nachricht...
.SendData MAIL FROM: < & AbsEMail & > & CR
If Not WaitForResponse(250) Then GoTo Send_End
-> Empfänger-Daten
.SendData RCPT TO: < + EmpfEMail + > + CR
If Not WaitForResponse(250) Then GoTo Send_End
-> Server mitteilen, daß jetzt DATEN gesendet werden
.SendData DATA & CR
If Not WaitForResponse(354) Then GoTo Send_End
-> Nachrichten-Header erstellen
Header = From: & AbsName & _
< & AbsEMail & > & CR & _
To: & EmpfName & < & EmpfEMail & > & CR & _
Date: & Format(Date, Ddd) & , & _
Format(Date, dd Mmm YYYY) & & _
Format(Time, hh:mm:ss) & & +0001 & CR & _
Subject: & Betreff & CR
-> WICHTIG!!!
-> Prüfen, ob innerhalb des Nachrichtentextes eine
-> Zeile nur aus einem einzigen Punkt enthält.
-> Wenn ja, unbedingt einen zweiten Punkt anfügen,
-> da ein einzelner Punkt das Ende der Nachricht
-> angibt!!!
iPos = InStr(Nachricht, vbCrLf & . & vbCrLf)
If iPos > 0 Then
Nachricht = Left$(Nachricht, iPos) & . & _
Mid$(Nachricht, iPos + 1)
End If
-> Jetzt Daten senden
.SendData Header & vbCrLf
While Nachricht <>
-> Paketweise zu je 1024 Bytes senden
.SendData Left$(Nachricht, 1024)
Nachricht = Mid$(Nachricht, 1025)
DoEvents
Wend
.SendData vbCrLf
.SendData vbCrLf & . & vbCrLf
If Not WaitForResponse(250) Then GoTo Send_End
-> Abmelden am Server
lblStatus.Caption = Abmelden vom Server...
.SendData QUIT & CR
If Not WaitForResponse(221) Then GoTo Send_End
MailSend = True
End If
End With
Send_End:
-> Verbindung beenden
lblStatus.Caption = Verbindung beenden...
Winsock1.Close
lblStatus.Caption = Bereit...
End Function
' Auf Antwort warten...
Public Function WaitForResponse(ByVal Response As _
String) As Boolean
-> spätestens nach 45 Sekunden abbrechen
Const TimeOut = 45
Dim iStart As Long
iStart = Timer
WaitForResponse = False
With Winsock1
While .Tag <> Response
-> Bei unvorhergesehenem Verbindungsabbruch
If .State > sckConnected And Response <> 221 Then
MsgBox Verbindungsabbruch!, 16, Error
Exit Function
End If
-> Wenn TimeOut überschritten, Meldung und abbrechen
If Timer - iStart > TimeOut Then
MsgBox TimeOut! & vbCrLf & _
Der Server antworte nicht..., 16, TimerOut
Exit Function
End If
DoEvents
Wend
.Tag =
End With
WaitForResponse = True
End Function
' Empfangen von Daten vom Server
Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)
Dim strDaten As String
Winsock1.GetData strDaten
frmStatus.txtStatus = frmStatus.txtStatus + strDaten
-> Wird für die Sub WaitForResponse benötigt
Winsock1.Tag = Left$(strDaten, 3)
End Sub
