# Emails via winsock versenden



## diablofriends (4. Oktober 2004)

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 (4. Oktober 2004)

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


----------



## diablofriends (4. Oktober 2004)

Ich hab diesen Programm aus diesem Link hier.


----------

