Emails via winsock versenden

[diablofriends]

Hi

Ich möchte das dieser programm mein email konnto einlogt so wie Outlook Express, aber weiss net wie ich das machen soll.Dieses Programm kann sich nicht bei smtp.web.de einlogen.Anscheinend muss er sich einlogen mit Konntoname und kennwort hoffe ihr könnt mir weiterhelfen.


danke im voraus

Option Explicit

Dim Mailing As Boolean
Dim Result$, Sec%, TimeOut%

Const Server$ = "Ihre.MailServer.Domäne"
Const Absender$ = "Gudrun Gichtelgrund"
Const Email$ = "gundi@gichtelgrund.de"
Const Domain$ = "goetz-reinecke.de"

Private Sub Form_Load()
TimeOut = 20
Text1.Text = Server
Text2.Text = Absender
Text3.Text = Email
Text8.Text = TimeOut
ProgressBar1.Min = 0
ProgressBar1.Value = 0
ProgressBar1.Max = TimeOut * 5

Text1.SelStart = 0
Text1.SelLength = Len(Text1.Text)
End Sub

Private Sub Command1_Click()
If Mailing = False Then
If SendMail(Text1.Text, Text2.Text, Text3.Text, Text4.Text, _
Text5.Text, Text6.Text, Text7.Text) Then
MsgBox ("Email erfolgreich verschickt")
Else
MsgBox ("Fehler beim Versenden aufgetreten")
End If
Else
MsgBox ("Letzte EMail wird noch gesendet !")
End If
End Sub

Private Sub Text8_Change()
TimeOut = Val(Text8.Text)
End Sub

Private Sub Timer1_Timer()
Sec = Sec + 1
ProgressBar1.Value = Sec - 1
DoEvents
End Sub

Private Function Response(RCode$) As Boolean
Sec = 0
Timer1.Interval = 200
Timer1.Enabled = True
Response = True

Do While Left$(Result, 3) <> RCode
DoEvents
If Sec > TimeOut * 5 Then
If Len(Result) Then
ShowStatus ("SMTP Error! Falscher Rückgabewert")
Else
ShowStatus ("SMTP Error! Time out")
End If
Response = False
Exit Do
End If
Loop

Result = ""
ProgressBar1.Value = 0
Timer1.Enabled = False
End Function

Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)
Winsock1.GetData Result
End Sub

Private Sub ShowStatus(ByVal Text$)
Label7.Caption = Text
Label7.Refresh
End Sub

Private Function SendMail(SMTP$, FromName$, FromMail$, ToName$, _
ToMail$, Subj$, Body$) As Boolean

Dim MAIL$, outTO$, outFR$
If Mailing = True Then Exit Function
Mailing = True
MousePointer = vbHourglass

If Winsock1.State = sckClosed Then
On Error GoTo ERRORMail
Winsock1.LocalPort = 0
outFR = "mail from: " & FromMail & vbCrLf
outTO = "rcpt to: " & ToMail & vbCrLf & "data" & vbCrLf

MAIL = MAIL & "From: " & FromName & " <" & FromMail & ">"
MAIL = MAIL & vbCrLf & "Date: " & Format(Date, "Ddd")
MAIL = MAIL & ", " & Format(Date, "dd Mmm YYYY") & " "
MAIL = MAIL & Format(Time, "hh:mm:ss") & " +0100" & vbCrLf
MAIL = MAIL & "X-Mailer: Visual Basic Mailing Tester"
MAIL = MAIL & vbCrLf & "To: " & ToName & " <" & ToMail & ">"
MAIL = MAIL & vbCrLf & "Subject: " & Subj & vbCrLf
MAIL = MAIL & vbCrLf & Body & vbCrLf & vbCrLf & "." & vbCrLf

'### Verbindung aufbauen
ShowStatus ("Verbinde...")
Winsock1.Protocol = sckTCPProtocol
Winsock1.RemoteHost = SMTP
Winsock1.RemotePort = 25
Winsock1.Connect
If Not Response("220") Then GoTo ERRORMail

'### Verbunden
ShowStatus ("Verbunden")
Winsock1.SendData ("HELO " & Domain & vbCrLf)
If Not Response("250") Then GoTo ERRORMail

'### Mail Senden
ShowStatus ("Nachricht Senden")

'UPDATE am 28. September 2002
Winsock1.SendData (outFR)
If Not Response("250") Then GoTo ERRORMail

Winsock1.SendData (outTO)
If Not Response("250") Then GoTo ERRORMail

Winsock1.SendData ("DATA" & vbCrLf)
If Not Response("354") Then GoTo ERRORMail

Winsock1.SendData (MAIL)
If Not Response("250") Then GoTo ERRORMail
'UPDATE ENDE

'### Trennen
ShowStatus ("Trennen")
Winsock1.SendData ("quit" & vbCrLf)
If Not Response("221") Then GoTo ERRORMail
ShowStatus ("Nachricht verschickt !")
SendMail = True
End If

ERRORMail:
Mailing = False
Winsock1.Close
MousePointer = vbDefault
Exit Function
End Function

 

[Shakie]

Ich dachte mit Winsock kann man blos eine Verbindung zwischen 2 PCs aufbauen und nicht mit einem (Mail-)Server!

 

[diablofriends]

Ich hab diesen Programm aus diesem Link hier.