28. März 2024, 16:56
VB-fun.de - Beitragsübersicht zum VB-/VBA-Forum-Archiv 0415
  VB6: smtp Abfrage ?
 Von micro
 Am 15. Dezember 2008 um 23:45:24
 Frage Hallo,
Ich würde gern per VB6 Emails versenden und
hab dazu diesen schönen Code gefunden(ActiveVB):
Option Explicit

Private Mailing As Boolean
Private Result As String
Private Sec As Integer
Private TimeOut As Integer

Private Const Server As String = "smtp.googlemail.com"
Private Const Absender As String = "Jupp Juppi"
Private Const Mail As String = " Jupp@Juppi.de"
Private Const Domain As String = "ActiveVB.de"

Private Sub Form_Load()
TimeOut = 20
Text1.Text = Server
Text2.Text = Absender
Text3.Text = Mail
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 ("E-Mail erfolgreich verschickt")
Else
MsgBox ("Fehler beim Versenden aufgetreten")
End If
Else
MsgBox ("Letzte E-Mail wird noch gesendet !")
End If
End Sub

Private Sub Frame2_DragDrop(Source As Control, X As Single, Y As Single)

End Sub

Private Sub Text7_Change()

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 As String, FromName As String, _
FromMail As String, ToName As String, ToMail As String, Subj As String, _
Body As String) As Boolean

Dim Mail As String, outTO As String, outFR As String

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
Nur leider habe ich das Problem, daß wenn ich über einen FreemailAccount senden will, an irgendeiner Stelle
Benutzernamen und Passwort übergeben werden müssen. Aber wo?

Kann mir jemand helfen ?

MfG micro
[ VB-/VBA-Forum | Archiv 0415 | Archiv-Übersicht ]
 Antworten
VB6: smtp Abfrage ? - micro 15. Dezember 2008 um 23:45:24
Re: smtp Abfrage ? - Peter Fleischer [MVP] 16. Dezember 2008 um 06:12:26
Re: smtp Abfrage ? - Peter Fleischer [MVP] 16. Dezember 2008 um 06:14:47

Zum Seitenanfang

Startseite | VB-/VBA-Tipps | Projekte | Tutorials | API-Referenz | Komponenten | Bücherecke | Gewinnspiele | VB-/VBA-Forum | DirectX | DirectX-Forum | VB.Net | VB.Net-Forum | Chat | Spielplatz | Links | Suchen | Stichwortverzeichnis | Feedback | Impressum