[VB6] Errore invio email con WinSock

[Andriy88]

Sono disperatissimo, non ci riesco a far ciò che voglio.

Ho un database Access con vari email dentro.
Dovrei recuperare tutte email e inviarle con WinSock

Questo è il codice che ho scritto:

Option Explicit
    Dim rs As ADODB.Recordset
    Dim curentMail As String
    Dim y As Integer
    Private WinsockState As WinsockControlState
    Dim strServerResponse   As String
    Dim strResponseCode     As String
    Dim strDataToSend       As String
    Private Enum WinsockControlState
        MAIL_CONNECT
        MAIL_HELO
        MAIL_FROM
        MAIL_RCPTTO
        MAIL_DATA
        MAIL_HEADER
        MAIL_DOT
        MAIL_QUIT
    End Enum

Private Sub Form_Load()
    WinSock.Protocol = sckTCPProtocol
    y = 0
    Set rs = New ADODB.Recordset
    rs.Open "SELECT Indirizzo FROM Email", "driver={Microsoft Access Driver (*.mdb)};dbq=C:\email.mdb", 1
    While rs.EOF = False
        y = y + 1
        WinSock.Connect Trim(txtEmailServer.Text), Val(Trim(txtEmailServerPort.Text))
        WinsockState = MAIL_CONNECT
        rs.MoveNext
        curentMail = LCase(rs("Indirizzo"))
        txtToEmailAddress.Text = "nome" & y & " <" & curentMail & ">"
    Wend
    rs.Close
End Sub

Private Sub WinSock_DataArrival(ByVal bytesTotal As Long)
    WinSock.GetData strServerResponse
    txtServerReplies.Text = txtServerReplies.Text & strServerResponse
    strResponseCode = Left(strServerResponse, 3)
    If strResponseCode = "250" Or strResponseCode = "220" Or strResponseCode = "354" Then
        Select Case WinsockState
            Case MAIL_CONNECT
                WinsockState = MAIL_HELO
                strDataToSend = Trim$(txtFromEmailAddress.Text)
                strDataToSend = Mid(strDataToSend, 1 + InStr(1, strDataToSend, "<"))
                strDataToSend = Left$(strDataToSend, InStr(1, strDataToSend, "@") - 1)
                WinSock.SendData "HELO " & strDataToSend & vbCrLf
            Case MAIL_HELO
                WinsockState = MAIL_FROM
                WinSock.SendData "MAIL FROM: " & Mid(txtFromEmailAddress.Text, InStr(1, txtFromEmailAddress.Text, "<")) & vbCrLf
            Case MAIL_FROM
                WinsockState = MAIL_RCPTTO
                WinSock.SendData "RCPT TO: " & Mid(txtToEmailAddress.Text, InStr(1, txtToEmailAddress.Text, "<")) & vbCrLf
            Case MAIL_RCPTTO
                WinsockState = MAIL_DATA
                WinSock.SendData "DATA" & vbCrLf
            Case MAIL_DATA
                WinsockState = MAIL_DOT
                WinSock.SendData "Return-Path: <" & txtFromEmailAddress.Text & ">" & vbCrLf & _
                "Content-type: text/plain" & vbCrLf & _
                "Priority: normal" & vbCrLf & _
                "To: " & txtToEmailAddress.Text & vbCrLf & _
                "From: " & txtFromEmailAddress.Text & vbCrLf & _
                "Subject:" & txtEmailSubject.Text & vbLf & vbCrLf
                Dim varLines    As Variant
                Dim varLine     As Variant
                Dim strMessage  As String
                strMessage = txtMessage.Text & vbCrLf & vbCrLf
                varLines = Split(strMessage, vbCrLf)
                strMessage = ""
                For Each varLine In varLines
                    WinSock.SendData CStr(varLine) & vbLf
                Next
                WinSock.SendData "." & vbCrLf
            Case MAIL_DOT
                WinsockState = MAIL_QUIT
                WinSock.SendData "QUIT" & vbCrLf
            Case MAIL_QUIT
                WinSock.Close
        End Select
    Else
        WinSock.Close
        If Not WinsockState = MAIL_QUIT Then
            If Left$(strServerResponse, 3) = 421 Then
                MsgBox "The from email address is invalid for this mail server.  Please check it and try again"
            Else
                MsgBox "Error: " & strServerResponse, vbCritical, "Error"
            End If
        Else
            MsgBox "Message sent!", vbOKOnly + vbInformation, App.Title
        End If
    End If
    WinSock.Close
End Sub

Quando lo compilo mi da un errore 40020 e mi porta sul questo rigo del codice:
-----
WinSock.Connect Trim(txtEmailServer.Text), Val(Trim(txtEmailServerPort.Text))
-----
1) Ho provato a eseguire solo il ciclo While che recupera le email dal db e mi funziona.
2) Provato a eseguire solo invio di un email con WinSock e mi funziona

Appena metto invio del email dentro il ciclo non me la invia più, si ferma al secondo giro del ciclo while.



Qualcuno per favore mi aiuti.

[oregon]

Ma perche' ti connetti al server piu' volte ... ?

Non capisco perche' la connessione al server all'interno del ciclo ...

E poi il winsock e' uno ... se e' connesso non lo puoi connettere un'altra volta ...

[Andriy88]

be non so neanche io quello che ho fatto
allora dovrei mettere:
-----
WinSock.Connect Trim(txtEmailServer.Text), Val(Trim(txtEmailServerPort.Text))
-----
fuori dal ciclo While?

Invece "WinsockState = MAIL_CONNECT" lasciare dentro??

Mi potrste aiutare a sistemare questo codice che ho scritto senza capire molto?

Sono alle prime armi con Visual Basic

[Andriy88]

Ora so perche avevo messo la connessione dentro il cliclo, perché avevo messo la chiusura della connesione WinSock nella Sub WinSock_DataArrival e pensavo che dovevo aprire e chiudere la connessione di WinSock per ogni linea del ciclo.

Ho riscritto il codice:

Sebra che funziona, cioé sembra , non mi da nessun errore nella compilazione e nell'esecuzione del programma. Però non invia email, ho inviato email a un altro mio account e non arriva. Potete dirmi se il codice è coretto? Vi prego..

Option Explicit
    Dim rs As ADODB.Recordset
    Dim y As Integer
    Private WinsockState As WinsockControlState
    Dim strServerResponse   As String
    Dim strResponseCode     As String
    Dim strDataToSend       As String
    Private Enum WinsockControlState
        MAIL_CONNECT
        MAIL_HELO
        MAIL_FROM
        MAIL_RCPTTO
        MAIL_DATA
        MAIL_HEADER
        MAIL_DOT
        MAIL_QUIT
    End Enum

Private Sub Form_Load()
    WinSock.Protocol = sckTCPProtocol
    WinSock.Connect Trim(txtEmailServer.Text), Val(Trim(txtEmailServerPort.Text))
    y = 0
    Set rs = New ADODB.Recordset
    rs.Open "SELECT Indirizzo FROM Email", "driver={Microsoft Access Driver (*.mdb)};dbq=C:\Documents and Settings\Andriy\Desktop\email.mdb", 1
    While rs.EOF
        y = y + 1
        WinsockState = MAIL_CONNECT
        rs.MoveNext
        txtToEmailAddress.Text = "nome" & y & " <" & rs("Indirizzo") & ">"
    Wend
    rs.Close
    WinSock.Close
End Sub

Private Sub WinSock_DataArrival(ByVal bytesTotal As Long)
    WinSock.GetData strServerResponse
    txtServerReplies.Text = txtServerReplies.Text & strServerResponse
    strResponseCode = Left(strServerResponse, 3)
    If strResponseCode = "250" Or strResponseCode = "220" Or strResponseCode = "354" Then
        Select Case WinsockState
            Case MAIL_CONNECT
                WinsockState = MAIL_HELO
                strDataToSend = Trim$(txtFromEmailAddress.Text)
                strDataToSend = Mid(strDataToSend, 1 + InStr(1, strDataToSend, "<"))
                strDataToSend = Left$(strDataToSend, InStr(1, strDataToSend, "@") - 1)
                WinSock.SendData "HELO " & strDataToSend & vbCrLf
            Case MAIL_HELO
                WinsockState = MAIL_FROM
                WinSock.SendData "MAIL FROM: " & Mid(txtFromEmailAddress.Text, InStr(1, txtFromEmailAddress.Text, "<")) & vbCrLf
            Case MAIL_FROM
                WinsockState = MAIL_RCPTTO
                WinSock.SendData "RCPT TO: " & Mid(txtToEmailAddress.Text, InStr(1, txtToEmailAddress.Text, "<")) & vbCrLf
            Case MAIL_RCPTTO
                WinsockState = MAIL_DATA
                WinSock.SendData "DATA" & vbCrLf
            Case MAIL_DATA
                WinsockState = MAIL_DOT
                WinSock.SendData "Return-Path: <" & txtFromEmailAddress.Text & ">" & vbCrLf & _
                "Content-type: text/plain" & vbCrLf & _
                "Priority: normal" & vbCrLf & _
                "To: " & txtToEmailAddress.Text & vbCrLf & _
                "From: " & txtFromEmailAddress.Text & vbCrLf & _
                "Subject:" & txtEmailSubject.Text & vbLf & vbCrLf
                Dim varLines    As Variant
                Dim varLine     As Variant
                Dim strMessage  As String
                strMessage = txtMessage.Text & vbCrLf & vbCrLf
                varLines = Split(strMessage, vbCrLf)
                strMessage = ""
                For Each varLine In varLines
                    WinSock.SendData CStr(varLine) & vbLf
                Next
                WinSock.SendData "." & vbCrLf
            Case MAIL_DOT
                WinsockState = MAIL_QUIT
                WinSock.SendData "QUIT" & vbCrLf
            Case MAIL_QUIT
                WinSock.Close
        End Select
    Else
        WinSock.Close
        If Not WinsockState = MAIL_QUIT Then
            If Left$(strServerResponse, 3) = 421 Then
                MsgBox "The from email address is invalid for this mail server.  Please check it and try again"
            Else
                MsgBox "Error: " & strServerResponse, vbCritical, "Error"
            End If
        Else
            MsgBox "Message sent!", vbOKOnly + vbInformation, App.Title
        End If
    End If
End Sub

[pprllo]

Mah ... Non credo tu possa fare così. Nel Form_Load devi inizializzare il WinSock e il RecordSet, ma poi non puoi fare qul while, altrimenti come fa il WinSock a fare lo scambio dati ? Devi invece cambiare la funzione DataArrival in modo che dopo aver terminato un invio non chiuda la connessione con il server ma invii il messaggio successivo.

[pprllo]

Una cosa tipo:

Option Explicit
    Dim rs As ADODB.Recordset
    Dim y As Integer
    Private WinsockState As WinsockControlState
    Dim strServerResponse   As String
    Dim strResponseCode     As String
    Dim strDataToSend       As String
    Private Enum WinsockControlState
        MAIL_CONNECT
        MAIL_HELO
        MAIL_FROM
        MAIL_RCPTTO
        MAIL_DATA
        MAIL_HEADER
        MAIL_DOT
        MAIL_QUIT
    End Enum

Private Sub Form_Load()
    WinSock.Protocol = sckTCPProtocol
    WinSock.Connect Trim(txtEmailServer.Text), Val(Trim(txtEmailServerPort.Text))
    y = 0
    Set rs = New ADODB.Recordset
    rs.Open "SELECT Indirizzo FROM Email", "driver={Microsoft Access Driver (*.mdb)};dbq=C:\Documents and Settings\Andriy\Desktop\email.mdb", 1

End Sub

    While rs.EOF
        y = y + 1
        WinsockState = MAIL_CONNECT
        rs.MoveNext
        txtToEmailAddress.Text = "nome" & y & " <" & rs("Indirizzo") & ">"
    Wend

Private Sub WinSock_DataArrival(ByVal bytesTotal As Long)
    WinSock.GetData strServerResponse
    txtServerReplies.Text = txtServerReplies.Text & strServerResponse
    strResponseCode = Left(strServerResponse, 3)
    If strResponseCode = "250" Or strResponseCode = "220" Or strResponseCode = "354" Then
        Select Case WinsockState
            Case MAIL_CONNECT
                WinsockState = MAIL_HELO
                strDataToSend = Trim$(txtFromEmailAddress.Text)
                strDataToSend = Mid(strDataToSend, 1 + InStr(1, strDataToSend, "<"))
                strDataToSend = Left$(strDataToSend, InStr(1, strDataToSend, "@") - 1)
                WinSock.SendData "HELO " & strDataToSend & vbCrLf
            Case MAIL_HELO
                WinsockState = MAIL_FROM
                WinSock.SendData "MAIL FROM: " & Mid(txtFromEmailAddress.Text, InStr(1, txtFromEmailAddress.Text, "<")) & vbCrLf
            Case MAIL_FROM
                WinsockState = MAIL_RCPTTO
                WinSock.SendData "RCPT TO: " & Mid(txtToEmailAddress.Text, InStr(1, txtToEmailAddress.Text, "<")) & vbCrLf
            Case MAIL_RCPTTO
                WinsockState = MAIL_DATA
                WinSock.SendData "DATA" & vbCrLf
            Case MAIL_DATA
                WinsockState = MAIL_DOT
                WinSock.SendData "Return-Path: <" & txtFromEmailAddress.Text & ">" & vbCrLf & _
                "Content-type: text/plain" & vbCrLf & _
                "Priority: normal" & vbCrLf & _
                "To: " & txtToEmailAddress.Text & vbCrLf & _
                "From: " & txtFromEmailAddress.Text & vbCrLf & _
                "Subject:" & txtEmailSubject.Text & vbLf & vbCrLf
                Dim varLines    As Variant
                Dim varLine     As Variant
                Dim strMessage  As String
                strMessage = txtMessage.Text & vbCrLf & vbCrLf
                varLines = Split(strMessage, vbCrLf)
                strMessage = ""
                For Each varLine In varLines
                    WinSock.SendData CStr(varLine) & vbLf
                Next
                WinSock.SendData "." & vbCrLf
            Case MAIL_DOT
                If rs.EOF then
                    WinsockState = MAIL_QUIT
                    WinSock.SendData "QUIT" & vbCrLf
                Else
                    y = y + 1
                    rs.MoveNext
                    txtToEmailAddress.Text = "nome" & y & " <" & rs("Indirizzo") & ">"
                    WinsockState = MAIL_FROM
                    WinSock.SendData "MAIL FROM: " & Mid(txtFromEmailAddress.Text, InStr(1, txtFromEmailAddress.Text, "<")) & vbCrLf
                End If
            Case MAIL_QUIT
                WinSock.Close
                rs.Close
        End Select
    Else
        WinSock.Close
        If Not WinsockState = MAIL_QUIT Then
            If Left$(strServerResponse, 3) = 421 Then
                MsgBox "The from email address is invalid for this mail server.  Please check it and try again"
            Else
                MsgBox "Error: " & strServerResponse, vbCritical, "Error"
            End If
        Else
            MsgBox "Message sent!", vbOKOnly + vbInformation, App.Title
        End If
    End If
End Sub

[Andriy88]

non posso mettere il While fuori da un Sub altrimenti mi da un errore. Ho provati in vari modi mettere il ciclo While in altri Sub che poi li ricchiamavo con un tasto ma niente, non esegue il while e nemmeno invia email

[pprllo]

Cough ... è un errore ho sbagliato a metterlo (avevo fatto un copia/incolla !)

Option Explicit
    Dim rs As ADODB.Recordset
    Dim y As Integer
    Private WinsockState As WinsockControlState
    Dim strServerResponse   As String
    Dim strResponseCode     As String
    Dim strDataToSend       As String
    Private Enum WinsockControlState
        MAIL_CONNECT
        MAIL_HELO
        MAIL_FROM
        MAIL_RCPTTO
        MAIL_DATA
        MAIL_HEADER
        MAIL_DOT
        MAIL_QUIT
    End Enum

Private Sub Form_Load()
    WinSock.Protocol = sckTCPProtocol
    WinSock.Connect Trim(txtEmailServer.Text), Val(Trim(txtEmailServerPort.Text))
    y = 0
    Set rs = New ADODB.Recordset
    rs.Open "SELECT Indirizzo FROM Email", "driver={Microsoft Access Driver (*.mdb)};dbq=C:\Documents and Settings\Andriy\Desktop\email.mdb", 1

End Sub

Private Sub WinSock_DataArrival(ByVal bytesTotal As Long)
    WinSock.GetData strServerResponse
    txtServerReplies.Text = txtServerReplies.Text & strServerResponse
    strResponseCode = Left(strServerResponse, 3)
    If strResponseCode = "250" Or strResponseCode = "220" Or strResponseCode = "354" Then
        Select Case WinsockState
            Case MAIL_CONNECT
                WinsockState = MAIL_HELO
                strDataToSend = Trim$(txtFromEmailAddress.Text)
                strDataToSend = Mid(strDataToSend, 1 + InStr(1, strDataToSend, "<"))
                strDataToSend = Left$(strDataToSend, InStr(1, strDataToSend, "@") - 1)
                WinSock.SendData "HELO " & strDataToSend & vbCrLf
            Case MAIL_HELO
                WinsockState = MAIL_FROM
                WinSock.SendData "MAIL FROM: " & Mid(txtFromEmailAddress.Text, InStr(1, txtFromEmailAddress.Text, "<")) & vbCrLf
            Case MAIL_FROM
                WinsockState = MAIL_RCPTTO
                WinSock.SendData "RCPT TO: " & Mid(txtToEmailAddress.Text, InStr(1, txtToEmailAddress.Text, "<")) & vbCrLf
            Case MAIL_RCPTTO
                WinsockState = MAIL_DATA
                WinSock.SendData "DATA" & vbCrLf
            Case MAIL_DATA
                WinsockState = MAIL_DOT
                WinSock.SendData "Return-Path: <" & txtFromEmailAddress.Text & ">" & vbCrLf & _
                "Content-type: text/plain" & vbCrLf & _
                "Priority: normal" & vbCrLf & _
                "To: " & txtToEmailAddress.Text & vbCrLf & _
                "From: " & txtFromEmailAddress.Text & vbCrLf & _
                "Subject:" & txtEmailSubject.Text & vbLf & vbCrLf
                Dim varLines    As Variant
                Dim varLine     As Variant
                Dim strMessage  As String
                strMessage = txtMessage.Text & vbCrLf & vbCrLf
                varLines = Split(strMessage, vbCrLf)
                strMessage = ""
                For Each varLine In varLines
                    WinSock.SendData CStr(varLine) & vbLf
                Next
                WinSock.SendData "." & vbCrLf
            Case MAIL_DOT
                If rs.EOF then
                    WinsockState = MAIL_QUIT
                    WinSock.SendData "QUIT" & vbCrLf
                Else
                    y = y + 1
                    rs.MoveNext
                    txtToEmailAddress.Text = "nome" & y & " <" & rs("Indirizzo") & ">"
                    WinsockState = MAIL_FROM
                    WinSock.SendData "MAIL FROM: " & Mid(txtFromEmailAddress.Text, InStr(1, txtFromEmailAddress.Text, "<")) & vbCrLf
                End If
            Case MAIL_QUIT
                WinSock.Close
                rs.Close
        End Select
    Else
        WinSock.Close
        If Not WinsockState = MAIL_QUIT Then
            If Left$(strServerResponse, 3) = 421 Then
                MsgBox "The from email address is invalid for this mail server.  Please check it and try again"
            Else
                MsgBox "Error: " & strServerResponse, vbCritical, "Error"
            End If
        Else
            MsgBox "Message sent!", vbOKOnly + vbInformation, App.Title
        End If
    End If
End Sub

Vedi che succede così.

[Andriy88]

ma fino a quante email posso inviare con questo script dal database?
celafa inviare 5000 email una dopo altra o il server di email esplode?

[Andriy88]

il script non da nessun errore però email non mi arrivano, forse perche sono troppe nel database, sono rirca 4000. Dopo un può di tempo si blocca script e dice che non riesce a collegarsi al server e poi mi escono finestre di norton anti virus dicendo che non si può inviare email, esce 1 finestra x ogni email non inviata quando il server smtp non risponde