运行后出现如下的错误提示：
SMTP service error, impromper response code. Code should have been:250 Code recieved: 501 Bad address syntax.
那么程序即只运行的红色部分了，该如何处理呢？帮帮忙！不胜感激!
Public Response As String, Reply As Integer, DateNow As String
Public Start As Single, Tmr As Single
Private Declare Function ArrPtr Lib "msvbvm60.dll" _
Alias "VarPtr" (Ptr() As Any) As Long '<-- VB6
'PokeLng:转换地址的内容
Private Declare Sub PokeLng Lib "kernel32" Alias "RtlMoveMemory" ( _
ByVal Addr As Long, Source As Long, _
Optional ByVal Bytes As Long = 4)
'Base64:
Private Base64EncodeByte(0 To 63) As Byte
Private Base64EncodeWord(0 To 63) As Integer
Const Base64EmptyByte As Byte = 61
Const Base64EmptyWord As Integer = 61
Public Sub Base64Init()
'建立Base64码表数组
Const Chars64 As String _
= "ABCDEFGHIJKLMNOPQRSTUVWXYZ" _
& "abcdefghijklmnopqrstuvwxyz" _
& "0123456789+/"
Static i As Long
Dim Code As Integer
If i Then Exit Sub
For i = 0 To 63
Code = Asc(Mid$(Chars64, i + 1, 1))
Base64EncodeByte(i) = Code
Base64EncodeWord(i) = Code
Next i
End Sub
Public Static Function Base64EncodeString(ByRef Text As String) As String
'Base64码转换函数
Dim Chars() As Integer
Dim SavePtr As Long
Dim SADescrPtr As Long
Dim DataPtr As Long
Dim CountPtr As Long
Dim TextLen As Long
Dim i As Long
Dim Chars64() As Integer
Dim SavePtr64 As Long
Dim SADescrPtr64 As Long
Dim DataPtr64 As Long
Dim CountPtr64 As Long
Dim TextLen64 As Long
Dim j As Long
Dim b1 As Integer
Dim b2 As Integer
Dim b3 As Integer
j = 0
TextLen = Len(Text)
If TextLen = 0 Then Exit Function
'输入字符串校验,长度不能为0
TextLen64 = ((TextLen + 2) \ 3) * 4
'输入字符串的转换为Base64码后的长度
Base64EncodeString = Space$(TextLen64)
If SavePtr = 0 Then
ReDim Chars(1 To 1)
SavePtr = VarPtr(Chars(1))
'SavePtr=*Chars(1)
PokeLng VarPtr(SADescrPtr), ByVal ArrPtr(Chars)
'*SADescrPtr=*Chars
DataPtr = SADescrPtr + 12
CountPtr = SADescrPtr + 16
ReDim Chars64(0 To 0)
SavePtr64 = VarPtr(Chars64(0))
' SavePtr64=*Chars64(0)
PokeLng VarPtr(SADescrPtr64), ByVal ArrPtr(Chars64)
'*SADescrPtr64=*Chars64
DataPtr64 = SADescrPtr64 + 12
CountPtr64 = SADescrPtr64 + 16
End If
PokeLng DataPtr, StrPtr(Text)
'DataPtr=*Text
PokeLng CountPtr, TextLen
'CountPtr=TextLen
PokeLng DataPtr64, StrPtr(Base64EncodeString)
'DataPtr64=*Base64EncodeString
PokeLng CountPtr64, TextLen64
'CountPtr64=Textlen64
Base64Init
'输入字符串转换为Base64码
For i = 1 To TextLen - 2 Step 3
'输入字符
b1 = Chars(i)
b2 = Chars(i + 1)
b3 = Chars(i + 2)
'Base64-Bytes:
Chars64(j) = Base64EncodeWord(b1 \ &H4)
Chars64(j + 1) = Base64EncodeWord((b1 And &H3) * &H10 + b2 \ &H10)
Chars64(j + 2) = Base64EncodeWord((b2 And &HF) * &H4 + b3 \ &H40)
Chars64(j + 3) = Base64EncodeWord(b3 And &H3F)
j = j + 4
Next i
'继续转换未转换完的输入字符Base64码
Select Case TextLen - i
Case 0 '2 Bytes
b1 = Chars(i)
Chars64(j) = Base64EncodeWord(b1 \ &H4)
Chars64(j + 1) = Base64EncodeByte((b1 And &H3) * &H10)
Chars64(j + 2) = Base64EmptyWord
Chars64(j + 3) = Base64EmptyWord
Case 1 '1 Byte
b1 = Chars(i)
b2 = Chars(i + 1)
Chars64(j) = Base64EncodeWord(b1 \ &H4)
Text1.Text = Chars64(j)
Chars64(j + 1) = Base64EncodeWord((b1 And &H3) * &H10 + b2 \ &H10)
Chars64(j + 2) = Base64EncodeWord((b2 And &HF) * &H4)
Chars64(j + 3) = Base64EmptyWord
End Select
'返回转换成Base64码的字符串
PokeLng DataPtr64, SavePtr64
PokeLng CountPtr64, 1
PokeLng DataPtr, SavePtr
PokeLng CountPtr, 1
End Function
Sub SendEmail(MailServerName As String, FromName As String, _
FromEmailAddress As String, ToName As String, ToEmailAddress As String, _
EmailSubject As String, EmailBodyOfMessage As String, EmialPassword As String, _
EmialUsername As String, NeedCheck As Integer)
Dim first As String, Second As String, Third As String
Dim Fourth As String, Fifth As String, Sixth As String
Dim Seventh As String, Eighth As String
Winsock1.LocalPort = 0 '用端口 0 来动态地建立连接
If Winsock1.State = sckClosed Then '检查winsock状态为关闭
' 发件人地址,vbCrLf输入框中的内容自动换行
first = "mail from:" + Chr(32) + FromEmailAddress + vbCrLf
' 收件人地址
Second = "rcpt to:" + Chr(32) + ToEmailAddress + vbCrLf
' 时间
Third = "Date:" + Chr(32) + Format(Date, "Ddd") & ", " & _
Format(Date, "dd Mmm YYYY") & " " & Format(Time, "hh:mm:ss") & _
"" & " -0600" + vbCrLf
' 发件人
Fourth = "From:" + Chr(32) + FromName + vbCrLf
' 收件人
Fifth = "To:" + Chr(32) + ToNametxt + vbCrLf
' 邮件主题
Sixth = "Subject:" + Chr(32) + EmailSubject + vbCrLf
' 邮件正文
Seventh = EmailBodyOfMessage + vbCrLf
Ninth = "X-Mailer: lj v 2.x" + vbCrLf
Eighth = Fourth + Third + Ninth + Fifth + Sixth
Winsock1.Protocol = sckTCPProtocol ' 设置protocol 为TCP
Winsock1.RemoteHost = MailServerName ' SMTP地址
Winsock1.RemotePort = 25 ' SMTP端口
Winsock1.Connect ' 开始连接
WaitFor ("220")
StatusTxt.Caption = "Connecting...."
StatusTxt.Refresh
Winsock1.SendData ("HELO worldcomputers.com" + vbCrLf)
WaitFor ("250")
StatusTxt.Caption = "Connected"
StatusTxt.Refresh
If NeedCheck = 1 Then
'进行校验
Winsock1.SendData ("AUTH LOGIN" + vbCrLf)
StatusTxt.Caption = "LOGIN ESMTP"
StatusTxt.Refresh
WaitFor ("334")
'输入用户名
Winsock1.SendData (Base64EncodeString(EmialUsername) + vbCrLf)
'用户名要转换成Base64码
StatusTxt.Caption = "username"
StatusTxt.Refresh
WaitFor ("334")
'输入口令
Winsock1.SendData (Base64EncodeString(EmialPassword) + vbCrLf)
'用户名要转换成Base64码
StatusTxt.Caption = "password"
StatusTxt.Refresh
WaitFor ("235")
End If
Winsock1.SendData (first)
StatusTxt.Caption = "Sending Message"
StatusTxt.Refresh
WaitFor ("250")
Winsock1.SendData (Second)
WaitFor ("250")
Winsock1.SendData ("data" + vbCrLf)
WaitFor ("354")
Winsock1.SendData (Eighth + vbCrLf)
Winsock1.SendData (Seventh + vbCrLf)
Winsock1.SendData ("." + vbCrLf)
WaitFor ("250")
Winsock1.SendData ("quit" + vbCrLf)
StatusTxt.Caption = "Disconnecting"
StatusTxt.Refresh
WaitFor ("221")
Winsock1.Close
Else
MsgBox (Str(Winsock1.State))
End If
End Sub
Sub WaitFor(ResponseCode As String)
'检查是否收到SMTP服务器返回代码
Start = Timer
While Len(Response) = 0
Tmr = Timer - Start
DoEvents
If Tmr > 50 Then
MsgBox "SMTP service error, timed out while waiting for response", 64, MsgTitle
Exit Sub
End If
Wend
While Left(Response, 3) <> ResponseCode
Tmr = Timer - Start
DoEvents
If Tmr > 50 Then
MsgBox "SMTP service error, impromper response code. Code should have been: " + _
ResponseCode + " Code recieved: " + Response, 64, MsgTitle
Exit Sub
End If
Wend
Response = "" ' Response清空
End Sub
Private Sub Command1_Click()
SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, _
txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, _
txtEmailBodyOfMessage.Text, txtFromEmialPassword.Text, txtFromEmialUsername.Text, _
EmailNeedCheck.Value
StatusTxt.Caption = "Mail Sent"
StatusTxt.Refresh
Beep
Close
End Sub
Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)
' 接收SMTP服务器信息
Winsock1.GetData Response
End Sub
[此贴子已经被作者于2006-6-13 13:18:43编辑过]
