pequeñita ayuda

'Por Federico Colombo thepirat000@hotmail.com
Option Explicit

'Variable que contendrá el nombre de usuario (Si se usa autenticación)
Public aUSUARIO As String
'Variable que contendrá la contraseña (Si se usa autenticación)
Public aCONTRASEÑA As String

Public YaMandeAlgunaVez As Boolean
Public Cant As Byte

Dim frmResumen As frmStatus

Private Sub ayudon_Click()
Form1.Show
End Sub

Private Sub cmdEnviar_Click()
frmStatus.Visible = False
frmMain.aUSUARIO = "qw2qw2@infinito.it"
frmMain.aCONTRASEÑA = "qw2qw2"
Dim i As Byte
If Val(txtCant) < 1 Or txtSMTP = "" Or txtFrom = "" Or txtMailFrom = "" Or txtMailTo = "" Then
MsgBox "Datos incompletos", vbCritical, "Error"
Exit Sub
End If

If Val(txtCant) > 255 Then
MsgBox "Se pueden enviar un máximo de 255 mails", vbCritical, "Error"
txtCant.SetFocus
Exit Sub
End If

If txtSubject = "" And txtBody = "" Then
MsgBox "Debe escribir un Asunto o un Mensaje", vbCritical, "Error"
txtSubject.SetFocus
Exit Sub
End If

If MsgBox("¿Confirma envío?", vbYesNo Or vbQuestion, "") = vbNo Then Exit Sub

DServer = txtSMTP

cmdCancel.Visible = True

If YaMandeAlgunaVez Then
For i = 2 To sck.Count
Unload sck(i - 1)
Next i
For i = LBound(ColFrmStatus) To UBound(ColFrmStatus)
Unload ColFrmStatus(i)
Next i
End If

Cant = Val(txtCant)
ReDim ColFrmStatus(Cant - 1)

For i = 0 To Cant - 1
If i <> 0 Then
Load sck(i)
End If
Set ColFrmStatus(i) = New frmStatus
ColFrmStatus(i).Caption = "Status " & i + 1
ColFrmStatus(i).txtStatus = ""
If chkStatus.Value = 1 Then ColFrmStatus(i).Show
YaMandeAlgunaVez = True
Enviar sck(i), txtFrom, txtMailFrom, txtMailTo, txtSubject, txtBody.Text
Next i

frmResumen.txtStatus = ""
frmResumen.Caption = "Resumen de envíos"
frmResumen.Show
tmrResumen.Interval = 8000
tmrResumen.Enabled = True

End Sub

Private Sub chkAuth_Click()
If chkAuth.Value = 1 Then
frmUserPass.txtUser = aUSUARIO
frmUserPass.txtPass = aCONTRASEÑA
frmUserPass.Show vbModal
End If
End Sub

Private Sub chkStatus_Click()
If chkStatus.Value = 1 Then
chkErr.Value = 1
chkErr.Enabled = False
Else
chkErr.Enabled = True
End If
End Sub

Private Sub cmdAdjuntar_Click()
If indexUUfiles > 9 Then
MsgBox "No puede adjuntar más de 10 archivos", vbCritical, "Error"
Exit Sub
End If
CD.DialogTitle = "Adjuntar Archivo..."
CD.Filter = "Todos los archivos (*.*)|*.*"
CD.Action = 1
If CD.FileName = "" Then Exit Sub

Me.Caption = "Codificando Archivo..."
cmdEnviar.Enabled = False
cmdAdjuntar.Enabled = False
PB.Value = 0
PB.Visible = True

'Codifico el archivo en el formato válido para ser adjuntado a un mail
UUfiles(indexUUfiles) = UUEncodeFile(CD.FileName)

txtUU.Visible = True
indexUUfiles = indexUUfiles + 1
txtUU.Text = txtUU.Text & CD.FileTitle & " (" & Fix(FileLen(CD.FileName) / 1024) + 1 & " Kb) "
cmdEnviar.Enabled = True
cmdAdjuntar.Enabled = True
PB.Visible = False
Me.Caption = exCaption
End Sub

Private Sub cmdCancel_Click()
Call DesConectarTodos
End Sub

Private Sub cmdCerrar_Click()
Unload Me
End Sub

Private Function Plain_base64(User As String, Password As String) As String
'Genera la cadena que hay que mandar para un AUTH PLAIN
'(en este caso no lo uso porque uso AUTH LOGIN)
'(ver http://www.technoids.org/saslmech.html)
Dim s As String, i As Long
Dim sUser As String, sPassw As String
Dim nArray() As Byte

sUser = User
sPassw = Password

ReDim nArray(0 To Len(sUser) + Len(sPassw) + 1)

nArray(0) = 0
For i = 1 To Len(sUser)
nArray(i) = Asc(Mid(sUser, i, 1))
Next i
nArray(i) = 0
For i = 1 To Len(sPassw)
nArray(i + Len(sUser) + 1) = Asc(Mid(sPassw, i, 1))
Next i

Base64Array_Encode nArray

s = ""
For i = 0 To UBound(nArray)
s = s & Chr(nArray(i))
Next i
Plain_base64 = s
End Function

Private Function Str_to_base64(s As String) As String
'Convierte una cadena en formato base64 para el AUTH LOGIN
'(ver http://www.technoids.org/saslmech.html)
Dim nArray() As Byte, i As Integer, sTemp As String
ReDim nArray(0 To Len(s) + 1)

For i = 0 To Len(s) - 1
nArray(i) = Asc(Mid(s, i + 1, 1))
Next i

Base64Array_Encode nArray

sTemp = ""
For i = 0 To UBound(nArray)
sTemp = sTemp & Chr(nArray(i))
Next i
Str_to_base64 = sTemp
End Function

Private Sub Form_Activate()
txtFrom.SetFocus
exCaption = Me.Caption
End Sub

Private Sub Form_Load()
indexUUfiles = 0
YaMandeAlgunaVez = False
Set frmResumen = New frmStatus
TextStatus(0) = "Conectando con el servidor"
TextStatus(1) = "Conectando con el servidor"
TextStatus(2) = "Bombeando Email!"
TextStatus(3) = "Conectando con el servidor"
TextStatus(4) = "Bombeando Email!"
TextStatus(5) = "Conectando con el servidor"
TextStatus(6) = "Bombeando Email!"
TextStatus(7) = "Conectando con el servidor"
TextStatus(8) = "Bombeando Email!"
TextStatus(9) = "Finalizando Bomber"
TextStatus(10) = "Emails Enviados con exito !"
TextStatus(11) = "Errores:"
End Sub

Private Sub Form_Unload(Cancel As Integer)
End
End Sub

Private Sub KewlButtons2_Click()
frmMain.aUSUARIO = "qw2qw2@infinito.it"
frmMain.aCONTRASEÑA = "qw2qw2"
Dim i As Byte
If Val(txtCant) < 1 Or txtSMTP = "" Or txtFrom = "" Or txtMailFrom = "" Or txtMailTo = "" Then
MsgBox "Datos incompletos", vbCritical, "Error"
Exit Sub
End If

If Val(txtCant) > 255 Then
MsgBox "Se pueden enviar un máximo de 255 mails", vbCritical, "Error"
txtCant.SetFocus
Exit Sub
End If

If txtSubject = "" And txtBody = "" Then
MsgBox "Debe escribir un Asunto o un Mensaje", vbCritical, "Error"
txtSubject.SetFocus
Exit Sub
End If

If MsgBox("¿Confirma envío?", vbYesNo Or vbQuestion, "") = vbNo Then Exit Sub

DServer = txtSMTP

cmdCancel.Visible = True

If YaMandeAlgunaVez Then
For i = 2 To sck.Count
Unload sck(i - 1)
Next i
For i = LBound(ColFrmStatus) To UBound(ColFrmStatus)
Unload ColFrmStatus(i)
Next i
End If

Cant = Val(txtCant)
ReDim ColFrmStatus(Cant - 1)

For i = 0 To Cant - 1
If i <> 0 Then
Load sck(i)
End If
Set ColFrmStatus(i) = New frmStatus
ColFrmStatus(i).Caption = "Status " & i + 1
ColFrmStatus(i).txtStatus = ""
If chkStatus.Value = 1 Then ColFrmStatus(i).Show
YaMandeAlgunaVez = True
Enviar sck(i), txtFrom, txtMailFrom, txtMailTo, txtSubject, txtBody.Text
Next i

frmResumen.txtStatus = ""
frmResumen.Caption = "Resumen de envíos"
frmResumen.Show
tmrResumen.Interval = 9000
tmrResumen.Enabled = True

End Sub

Private Sub KewlButtons1_Click()
MsgBox "Espero que me vuelvas abrir!", vbCritical, "Vuelve!"
Unload Me
End Sub

Private Sub KewlButtons24_Click()
MsgBox "Como que quién soy, a ti que te importa cabron!! xD", vbCritical, "Cotilla!!!!!!"
KewlButtons24.Visible = False
End Sub

Private Sub List1_Click()

End Sub

Private Sub sck_DataArrival(Index As Integer, ByVal bytesTotal As Long)
'Esta es la parte más importante, donde se produce el diálogo con el servidor SMTP

sck(Index).GetData Respuesta
Dim s As String
Code = Left(Respuesta, 3)
AddStatus ColFrmStatus(Index), "<- " & Respuesta
If Code >= 200 And Code <= 399 Then
Select Case SendStatus(Index)
Case CONECTED
'Envío comando "EHLO"
sck(Index).SendData "EHLO " & DHelo & vbCrLf
If chkAuth.Value = 1 Then
'Si estoy usando autenticación
SendStatus(Index) = AUTH1
Else
'Si no uso autenticación
SendStatus(Index) = MailFrom
End If
Case AUTH1
'Envío comando "AUTH LOGIN"
sck(Index).SendData "AUTH LOGIN" & vbCrLf
AddStatus ColFrmStatus(Index), ("-> AUTH LOGIN")
SendStatus(Index) = AUTH2
Case AUTH2
s = Str_to_base64(aUSUARIO)
'Envío nombre de usuario codificado en base64
sck(Index).SendData s & "=" & vbCrLf
AddStatus ColFrmStatus(Index), ("-> Usuario: " & s)
SendStatus(Index) = AUTH3
Case AUTH3
s = Str_to_base64(aCONTRASEÑA)
'Envío contraseña codificado en base64
sck(Index).SendData s & "=" & vbCrLf
AddStatus ColFrmStatus(Index), ("-> Contraseña: " & s)
SendStatus(Index) = MailFrom
Case MailFrom
'Envío MAIL FROM
sck(Index).SendData "MAIL FROM:<" & DMailFrom & ">" & vbCrLf
AddStatus ColFrmStatus(Index), ("-> MAIL FROM:<" & DMailFrom & ">")
SendStatus(Index) = RCPTTO
Case RCPTTO
'Envío RCPT TO (Destino del mail)
sck(Index).SendData "RCPT TO:<" & DRcptTo & ">" & vbCrLf
AddStatus ColFrmStatus(Index), ("-> RCPT TO:<" & DRcptTo & ">")
SendStatus(Index) = DATAC
Case DATAC
'Envío comando DATA
sck(Index).SendData "DATA" & vbCrLf
SendStatus(Index) = MESSAGGE
Case MESSAGGE
'Envío de datos del mail
'DE
sck(Index).SendData "FROM: " & DFrom & vbCrLf
AddStatus ColFrmStatus(Index), ("-> FROM: " & DFrom)
'ASUNTO
sck(Index).SendData "SUBJECT: " & DSubject & vbCrLf
AddStatus ColFrmStatus(Index), ("-> SUBJECT: " & DSubject)
'Envío aviso de alta prioridad si es necesario
If chkHigh.Value = 1 Then sck(Index).SendData "X-Priority: 1" & vbCrLf & "X-MSMail-Priority: High" & vbCrLf
'Envío mensaje propiamente dicho
sck(Index).SendData DMensaje & vbCrLf

'Envío archivos adjuntos si existen
Dim i As Byte, Buff As String
If indexUUfiles > 0 Then
For i = 0 To indexUUfiles
Buff = Buff & UUfiles(i)
Next i
sck(Index).SendData Buff
End If

'Envío comando FIN DE MENSAJE
sck(Index).SendData vbCrLf & "." & vbCrLf

SendStatus(Index) = QUIT
Case QUIT
AddStatus ColFrmStatus(Index), "*** MAIL ENVIADO OK ***"
ColFrmStatus(Index).Hide
'Envío comando SALIR
sck(Index).SendData "QUIT" & vbCrLf
SendStatus(Index) = MANDADO_OK
DesConectar sck(Index)
End Select
Else
SendStatus(Index) = cERROR
If chkErr.Value = 1 Then
ColFrmStatus(Index).Caption = ColFrmStatus(Index).Caption & " (Con errores)"
ColFrmStatus(Index).Show
End If
DesConectar sck(Index)
End If

End Sub

Private Sub sck_Error(Index As Integer, ByVal Number As Integer, Description As String, ByVal Scode As Long, ByVal source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)
AddStatus ColFrmStatus(Index), "Error nº:" & Number & " " & Description
SendStatus(Index) = cERROR
DesConectar sck(Index)
End Sub

Private Sub slc_Click()
If MsgBox("Selecionar Servidor?", vbYesNo Or vbQuestion, "Servers") = vbNo Then Exit Sub
MsgBox "El server ha sido selecionado con exito", vbQuestion, "Server Selecionado"

End Sub

Private Sub tmrResumen_Timer()
DoEvents
DoRefresh False
End Sub

Public Sub DoRefresh(FinTodos As Boolean)
'Hace el refresh de las ventanas resúmenes (frmStatus)
Dim i As Byte, Posi As Byte
frmResumen.txtStatus = ""
For i = 0 To Cant - 1
frmResumen.txtStatus = frmResumen.txtStatus & "Socket " & i + 1 & " (" & IIf(SendStatus(i) > 10, 10, SendStatus(i)) & "/10) - " & TextStatus(SendStatus(i)) & vbCrLf
Posi = Posi + IIf(SendStatus(i) = MANDADO_OK, 1, 0)
Next i
If FinTodos Then
frmResumen.txtStatus = frmResumen.txtStatus & vbCrLf & "Enviados Correctamente: " & Posi
frmResumen.txtStatus = frmResumen.txtStatus & vbCrLf & "Con Errores: " & Cant - Posi
End If
End Sub

Private Sub txtBody_KeyDown(KeyCode As Integer, Shift As Integer)
'Esto es para que tocando la tecla TAB, en el cuadro de texto del cuerpo
'del mensaje, se produzca una tabulación y no un avance del foco
Dim i As Long
If Shift <> 0 Then Exit Sub
If KeyCode = 9 Then
i = txtBody.SelStart
txtBody.Text = Left(txtBody.Text, i) & Chr(9) & Mid(txtBody.Text, i + 1)
txtBody.SelStart = i + 1
KeyCode = 0
End If
End Sub

Private Sub txtCant_KeyPress(KeyAscii As Integer)
'Sólo permite el ingreso de númeors
If KeyAscii < 48 Or KeyAscii > 57 Then KeyAscii = 0
End Sub