'declaraciones
Dim Response As String, Reply As Integer, DateNow As String
Dim first As String, Second As String, Third As String
Dim Fourth As String, Fifth As String, Sixth As String
Dim Seventh As String, Eighth As String
Dim Start As Single, Tmr As Single
Sub SendEmail(MailServerName As String, FromName As String, FromEmailAddress As String, ToName As String, ToEmailAddress As String, EmailSubject As String, EmailBodyOfMessage As String)
Winsock1.LocalPort = 0 ' hay q poner el puerto a cero para poder mandar mas de 1 mail por cada vez q se abre el prog.
If Winsock1.State = sckClosed Then ' ver si el socket esta cerrado.
DateNow = Format(Date, "Ddd") & ", " & Format(Date, "dd Mmm YYYY") & " " & Format(Time, "hh:mm:ss") & "" & " -0600"
first = "mail from:" + Chr(32) + FromEmailAddress + vbCrLf ' Quien manda?
Second = "rcpt to:" + Chr(32) + ToEmailAddress + vbCrLf ' PAra quien es?
Third = "Date:" + Chr(32) + DateNow + vbCrLf ' fecha
Fourth = "From:" + Chr(32) + FromName + vbCrLf 'remitente
Fifth = "To:" + Chr(32) + ToNametxt + vbCrLf ' destinatario
Sixth = "Subject:" + Chr(32) + EmailSubject + vbCrLf ' asunto
Seventh = EmailBodyOfMessage + vbCrLf ' cuerpo del mail
Ninth = "X-Mailer: EBT Reporter v 2.x" + vbCrLf ' que programa lo manda? personalizá esto
Eighth = Fourth + Third + Ninth + Fifth + Sixth ' Combinar para un envío apropiado
Winsock1.Protocol = sckTCPProtocol ' Setear el protocolo para el envio
Winsock1.RemoteHost = MailServerName ' Setear la direccion del server
Winsock1.RemotePort = 25 ' Setear el puerto SMTP
Winsock1.Connect 'Iniciar conex.
WaitFor ("220")
StatusTxt.Caption = "Conectando...."
StatusTxt.Refresh
Winsock1.SendData ("HELO worldcomputers.com" + vbCrLf)
WaitFor ("250")
StatusTxt.Caption = "Connected"
StatusTxt.Refresh
Winsock1.SendData (first)
StatusTxt.Caption = "Sending Message"
StatusTxt.Refresh
WaitFor ("250")
Winsock1.SendData (Second)
WaitFor ("250")
Winsock1.SendData ("data" + vbCrLf)
WaitFor ("354")
Winsock1.SendData (Eighth + vbCrLf)
Winsock1.SendData (Seventh + vbCrLf)
Winsock1.SendData ("." + vbCrLf)
WaitFor ("250")
Winsock1.SendData ("quit" + vbCrLf)
StatusTxt.Caption = "Disconnecting"
StatusTxt.Refresh
WaitFor ("221")
Winsock1.Close
Else
MsgBox (Str(Winsock1.State))
End If
End Sub
Sub WaitFor(ResponseCode As String)
Start = Timer ' para q no se trabe en loop
While Len(Response) = 0
Tmr = Start - Timer
DoEvents ' deja el sistema esperando por una respuesta entrante **IMPORTANTE**
If Tmr > 50 Then ' tiempo para esperar (en segundos)
MsgBox "SMTP service error, timed out while waiting for response", 64, MsgTitle
Exit Sub
End If
Wend
While Left(Response, 3) <> ResponseCode
DoEvents
If Tmr > 50 Then
MsgBox "SMTP service error, impromper response code. Code should have been: " + ResponseCode + " Code recieved: " + Response, 64, MsgTitle
Exit Sub
End If
Wend
Response = "" ' Envia el codigo de respuesta en blanco. **IMPORTANTE**
End Sub
Private Sub Command1_Click()
SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtEmailBodyOfMessage.Text
'MsgBox ("Mail Sent")
StatusTxt.Caption = "Mail Enviado"
StatusTxt.Refresh
Beep
Close
End Sub
Private Sub Command2_Click()
End
End Sub
Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)
Winsock1.GetData Response ' Revisa por respuesta entrante *IMPORTANTE*
End Sub
este programita usa:
7 txtboxs:
txtFromEmailAddress
txtFromName
txtToEmailAddress
ToNametxt
txtEmailSubject
txtEmailServer
txtEmailBodyOfMessage
label: StatusTxt
2 botones, 1 winsock y 7 labels nombrado todo por default.
Screencap: