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 |
|