VB 中用winsock控件发邮件的问题

yingnvwuyan 2010-03-03 10:30:33

Dim strData As String
Dim Start As Single
Dim WaitTime As Single

Private Sub cmdSend_Click()
Dim sFrom As String
Dim sTo As String
Dim sSubject As String
Dim sDate As String
Dim sMaileType As String
Dim sMailHeader As String
Dim sMailBody As String
Dim blnOK As String

If Winsock1.State = sckClose Then
Winsock1.Protocol = sckTCPProtocol
Winsock1.RemoteHost = txtServer.Text
Winsock1.RemotePort = 25
blnOK = WaitforResponse("220")
If Not blnOK Then
StatusBar1.Panels(1).Text = "Status:Connection Fail"
StatusBar1.Refresh
Exit Sub
End If

StatusBar1.Panels(1).Text = "Status:Connecting.."
StatusBar1.Refresh
Winsock1.SendData "HELO" & txtServer.Text & vbCrLf
blnOK = WaitforResponse("250")
If Not blnOK Then
StatusBar1.Panels(1).Text = "Status:Connection Fail"
StatusBar1.Refresh
Exit Sub
End If
StatusBar1.Panels(1).Text=
"Status:Connected"
StatusBar1.Refresh
Winsock1.SendData "MAIL FORM:" & Trim
(txtFromAddress.Text) & vbCrLf
StatusBar1.Panels(1).Text = "Status:"
Sending Message"
StatusBar1.Refresh
blnOK = WaitforResponse("250")
If Not blnOK Then
StatusBar1.Panels(1).Text = "Status:"
Connection Fail"
StatusBar1.Refresh
Exit Sub
End If
Winsock1.SendData "RCPT TO:" & Trim
(txtToAddress.Text) & vbCrLF
blnOK = WaitforResponse("250")
If Not blnOK Then
StatusBar1.Panels(1).Text = "Status:"
Connection Fail"
StatusBar1.Refresh
Exit Sub
End If
Winsock1.SendData "DATA" & vbCrLf
blnOK = WaitforResponse("354")
If Not blnOK Then
StatusBar1.Panels(1).Text = "Status:"
Connection Fail"
StatusBar1.Refresh
Exit Sub
End If
'E-Mail Header
sFrom="From:"""& txtFromName.Text &
"""<" & Trim(txtFromAddress.Text) &">
" & vbCrLf
sTo = "To:"" & txtToName.Text & """ < ""
& Trim(txtTomAddress.Text) &"> " & vbCrLf
sSubject = "Subject: " & txtSubject.Text
& vbCrLf
sDate="Date: "& Format(Date "Ddd") &
"." & Format(Date. "dd Mmm YYYY") & "
" & Format(Time. "hh:mm:ss") & " +0800"
& vbCrLf
sMailType = "MIME-Version: 1.0" & vbCrLf
& "X-Mailer: lnternet Mail Service
(5.5.2448.0)" & vbCrLf
sMailHeader=sFrom & sTO & sSubject &
sDate & sMailType
Winsock1.SendData sMailHeader & vbCrLf
sMailBody = txtMessage.Text & vbCrLf
Winsock1.SendData sMailBody & vbCrLf
Winsock1.SendData vbCrLf & "." & vbCrLf
blnOK = WaitforResponse("250")

If Not blnk Then
StatusBar1.Panels(1).Text = "Status:"
Connection Fail"
StatusBar1.Refresh
Exit Sub
End If

Winsock1.SendData "OUIT" & vbCrLf
StatusBar1.Panels(1).Text = "Status:"
Disconnecting ""
StatusBar1.Refresh
blnOK=WaitforResponse("221)
If Not blnOK Then
StatusBar1.Panels(1).Text = "Status:"
Connection Fail"
StatusBar1.Refresh
Exit Sub
End If
Winsock1.Close
StatusBar1.Panels(1).Text = "Staus:"
Mail Sent"
StatusBar1.Refresh
End If
End Sub

Private Sub Winsock1_DataArrival(ByVal bytesTotal
As Long)
Winsock1.GetData strData
End Sub

Private Function WaitforResponse(ResponseCode As
Sting) As Boolean
Start = Timer
'SMTP Error: Time Out
Do White Len(strData)=0
WaitTime = Timer - Start
DoEvents
If WaitTime > 50 Then
MsgBox "SMTP Error : Tine Out". vbCritical
WaitforResponse = False
Exit Funtion
End If
Loop
'Winsock Error
Do While Left(strData, 3) <> ResponseCode
DoEvents
If WaitTime > 50 Then
MsgBox "SMTP Error:" & ResponseCode
& " " & strData ,vbCritical
WaitforResponse = False
Exit Function
End If
Loop

strData = ""
WaitforResponse = True
End Function

Private Sub cmdExit_Click()
If Winsock1.State <> scocked Then
Winsock1.Close
End If

End
End Sub

'为什么说WaitforResponse函数未定义，该怎么改呢

...全文