邮件发送不成功，如何通过验证。

mingtian2008 2005-04-20 05:49:26

今天试了试发邮件，但不好用。
我用的是 163的邮箱
它的SMTP 的服务器是不是 smtp.163.com

在测试时发送成功但，没有收到邮件下面是具体的代码，帮忙看看。
（不用MAPI 实现，不需要发附件）

'模块
'*******与服务器建立连接
'strServer 服务器地址，wsk 监听的 winsock ,StrSrvport 端口
Public Sub ConnectToServer(strServer As String, wsk As Winsock, Optional strSrvPort As String)
wsk.RemoteHost = strServer
If strSrvPort = "" Then
wsk.RemotePort = 25
Else
wsk.RemotePort = Val(strSrvPort)
End If
wsk.Connect
End Sub
'*****速度缓冲
Public Sub Wait(WaitTime)

Dim StartTime As Double
StartTime = Timer
Do While Timer < StartTime + WaitTime
If Timer > 86395 Or Timer = 0 Then Exit Do
DoEvents
Loop
End Sub

'邮件发送，参数依次为：发信人地址、收信人地址、标题、主体、WINSOCK、附件
Public Sub SendMail(strFrom As String, strTo As String, strSubject As String, strBody As TextBox, wsk As Winsock, Optional strAttachName As String, Optional txtEncodedFile As Control)

Dim intCount As Integer
Wait 0.5
wsk.SendData "EHLO " & wsk.LocalIP & vbCrLf
wsk.SendData "MAIL FROM:" & strFrom & vbCrLf
Wait 0.5
wsk.SendData "RCPT TO:" & strTo & vbCrLf
wsk.SendData "DATA" & vbCrLf
Wait 0.5
wsk.SendData "MIME-Version: 1.0" & vbCrLf
wsk.SendData "From: " & ExtractArgument(1, strFrom, "@") & " <" & strFrom & ">" & vbCrLf
wsk.SendData "To: <" & strTo & ">" & vbCrLf
wsk.SendData "Subject: " & strSubject & vbCrLf
wsk.SendData "Content-Type: multipart/mixed;" & vbCrLf
wsk.SendData " boundary=Unique-Boundary" & vbCrLf & vbCrLf
wsk.SendData " [ Random garbage here ]" & vbCrLf & vbCrLf
wsk.SendData vbCrLf & "--Unique-Boundary" & vbCrLf
wsk.SendData "Content-type: text/plain; charset=US-ASCII" & vbCrLf & vbCrLf
wsk.SendData strBody.Text & vbCrLf & vbCrLf

If LTrim(RTrim(strAttachName)) <> "" Then

For intCount = Len(strAttachName) To 1 Step -1

If Mid(strAttachName, intCount, 1) = "\" Then
strAttachName = Mid(strAttachName, intCount + 1)
GoTo lala
End If
Next intCount
lala:
wsk.SendData "--Unique-Boundary" & vbCrLf
wsk.SendData "Content-Type: multipart/parallel; boundary=Unique-Boundary-2" & vbCrLf & vbCrLf
wsk.SendData "--Unique-Boundary-2" & vbCrLf
wsk.SendData "Content-Type: application/octet-stream;" & vbCrLf
wsk.SendData " name=" & strAttachName & vbCrLf
wsk.SendData "Content-Transfer-Encoding: base64" & vbCrLf
wsk.SendData "Content-Disposition: inline;" & vbCrLf
wsk.SendData " filename=" & strAttachName & vbCrLf & vbCrLf
wsk.SendData txtEncodedFile.Text & "==" & vbCrLf
wsk.SendData "--Unique-Boundary-2----Unique-Boundary--"
End If
wsk.SendData vbCrLf & "." & vbCrLf
Wait 0.5
wsk.SendData "QUIT" & vbCrLf
Wait 0.5
wsk.Close
End Sub
Private Function ExtractArgument(ArgNum As Integer, srchstr As String, Delim As String) As String
'字符串处理
'比如ExtractArgument(3, "No 1, No 2, No 3", ",")，会返回No 3

On Error GoTo Err_ExtractArgument
Dim ArgCount As Integer
Dim LastPos As Integer
Dim Pos As Integer
Dim Arg As String
Arg = ""
LastPos = 1
If ArgNum = 1 Then Arg = srchstr
Do While InStr(srchstr, Delim) > 0
Pos = InStr(LastPos, srchstr, Delim)
If Pos = 0 Then
If ArgCount = ArgNum - 1 Then Arg = Mid(srchstr, LastPos)
Exit Do
Else
ArgCount = ArgCount + 1
If ArgCount = ArgNum Then
Arg = Mid(srchstr, LastPos, Pos - LastPos)
Exit Do
End If
End If
LastPos = Pos + 1
Loop
ExtractArgument = Arg
Exit Function
Err_ExtractArgument:
'MsgBox "错误" & Err & ": " & Error
Resume Next
End Function

'窗体----------
Private Sub cmdSend_Click()

ConnectToServer txtServer.Text, Winsock1

End Sub

Private Sub Winsock1_Connect()
Wait 0.5
SendMail txtFromAddress, txtToAddress, txtSubject, txtBody, Winsock1
MsgBox "发送成功！"
Winsock1.Close
End Sub

Private Sub Winsock1_Error(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)
MsgBox "发送失败,错误号:" & Number
Winsock1.Close
Exit Sub
End Sub

...全文