请高手帮我看一下这个发邮件程序怎么发不了邮件？

Question

按发送后在“sending message”处停住了，是什么问题呢？是不是这个程序要邮件服务器或者别的软件支持的呢？如果是要怎样设计呢？请帮忙看一下谢谢！Dim Response As String
Dim Reply As Integer
Dim DateNow As String
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
Dim Start As Single, Tmr As SingleSub SendEmail(MailServerName As String, FromName As String, _
    FromEmailAddress As String, ToName As String, _
    ToEmailAddress As String, EmailSubject As String, _
    EmailBodyOfMessage As String)Winsock1.LocalPort = 0
'端口设置为0,否则在启动程序的时候信就已经发出去了
    
If Winsock1.State = sckClosed Then
'如果Winsock关闭中
    DateNow = Format(Date, "Ddd") & ", " & Format(Date, "dd Mmm YYYY") _
        & " " & Format(Time, "hh:mm:ss") & "" & " -0600"
    first = "mail from:" + Chr(32) + FromEmailAddress + vbCrLf
    '获得发件人地址
    Second = "rcpt to:" + Chr(32) + ToEmailAddress + vbCrLf
    '收件人地址
    Third = "Date:" + Chr(32) + DateNow + vbCrLf
    '发件时间
    Fourth = "From:" + Chr(32) + FromName + vbCrLf
    ' 发件人姓名
    Fifth = "To:" + Chr(32) + ToNametxt + vbCrLf
    ' 收件人姓名
    Sixth = "Subject:" + Chr(32) + EmailSubject + vbCrLf
    ' 邮件主题
    Seventh = EmailBodyOfMessage + vbCrLf
    ' 邮件正文
    Eighth = Fourth + Third + Ninth + Fifth + Sixth  ' 生成SMTP发送邮件所必须的模式
    Ninth = "X-Mailer: EBT Reporter v 2.x" + vbCrLf  '发送邮件的软件名称,可以自定义    Winsock1.Protocol = sckTCPProtocol ' 设置发送的协议
    Winsock1.RemoteHost = MailServerName ' 设置服务器地址
    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
    '连接成功    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)
'等待回应
    Start = Timer
    '取得当前时间,秒为单位    While Len(Response) = 0
    '无响应
        Tmr = Start - Timer
        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
    '查看左面3个字符是否为所需要的字符(例如"250")
        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 = "" ' Sent response code to blank **IMPORTANT**
End Sub
Private Sub cmdSend_Click()
    SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtEmailBodyOfMessage.Text
    'MsgBox ("Mail Sent")
    StatusTxt.Caption = "Mail Sent"
    StatusTxt.Refresh
    Beep
    
    Close
End SubPrivate Sub cmdExit_Click()
    
    End
    
End Sub
Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)
'收到数据后
'把Winsock1的数据放到Response中
    Winsock1.GetData Response ' Check for incoming response *IMPORTANT*End Sub

Answer 1

Tmr = Start - Timer
        DoEvents
        '让系统保持检查响应
        If Tmr > 50 Then这里是的条件永远为假吧
因为TMR应该是个负值

Answer 2

楼上是说waitfor函数有问题吧，我把函数禁掉，可仍然发不了？

Answer 3

现在的邮件服务器需要用户验证，采用新的ESMTP协议，所以，去下一个例子再看吧~~
http://www.dapha.net/down/list.asp?id=2047

Answer 4

怎么搞这么复杂，直接用CDO不就行了

Answer 5

谢谢cso(sjxsoft)，我在网上找了下面代码，用163.net发送没问题，但用我公司的邮箱sat.com.hk发送在“接收人邮件地址”处便停住,是什么原因呢，我的邮箱是支持outlook的。
另外楼上说的CDO，我不太熟悉，能否介召一下，谢谢！
'程序组合：dapha(汪锋)
'下载http://www.dapha.net
'我是一名VB爱好者，希望得到大家的帮助，共同学习，进步
'转摘请保留以上信息，谢谢合作
Private Enum SMTP_State
    MAIL_CONNECT
    MAIL_HELO
    mail_from
    MAIL_RCPTTO
    MAIL_DATA
    MAIL_DOT
    MAIL_QUIT
    MAIL_USER
    MAIL_PASS
    mail_login
End Enum
Private m_State As SMTP_State
Private m_strEncodedFiles As String
Private Function Base64_Encode(strSource) As String 'base6加密算法
    Const BASE64_TABLE As String = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
    Dim strTempLine As String
    Dim j As Integer
    For j = 1 To (Len(strSource) - Len(strSource) Mod 3) Step 3
        strTempLine = strTempLine + Mid(BASE64_TABLE, (Asc(Mid(strSource, j, 1)) \ 4) + 1, 1)
        strTempLine = strTempLine + Mid(BASE64_TABLE, ((Asc(Mid(strSource, j, 1)) Mod 4) * 16 _
                      + Asc(Mid(strSource, j + 1, 1)) \ 16) + 1, 1)
        strTempLine = strTempLine + Mid(BASE64_TABLE, ((Asc(Mid(strSource, j + 1, 1)) Mod 16) * 4 _
                      + Asc(Mid(strSource, j + 2, 1)) \ 64) + 1, 1)
        strTempLine = strTempLine + Mid(BASE64_TABLE, (Asc(Mid(strSource, j + 2, 1)) Mod 64) + 1, 1)
    Next j
    If Not (Len(strSource) Mod 3) = 0 Then
         If (Len(strSource) Mod 3) = 2 Then
            strTempLine = strTempLine + Mid(BASE64_TABLE, (Asc(Mid(strSource, j, 1)) \ 4) + 1, 1)
            strTempLine = strTempLine + Mid(BASE64_TABLE, (Asc(Mid(strSource, j, 1)) Mod 4) * 16 _
                      + Asc(Mid(strSource, j + 1, 1)) \ 16 + 1, 1)
             strTempLine = strTempLine + Mid(BASE64_TABLE, (Asc(Mid(strSource, j + 1, 1)) Mod 16) * 4 + 1, 1)
            strTempLine = strTempLine & "="
        ElseIf (Len(strSource) Mod 3) = 1 Then
            strTempLine = strTempLine + Mid(BASE64_TABLE, Asc(Mid(strSource, j, 1)) \ 4 + 1, 1)
            strTempLine = strTempLine + Mid(BASE64_TABLE, (Asc(Mid(strSource, j, 1)) Mod 4) * 16 + 1, 1)
             strTempLine = strTempLine & "=="
        End If
     End If
    Base64_Encode = strTempLine
End Function
Private Sub cmdExit_Click()
Unload Me
End Sub
Private Sub CmdSend_Click()
    Winsock1.Close
    Winsock1.LocalPort = 0
    strserver = txtserver
    ColonPos = InStr(strserver, ":")
    If ColonPos = 0 Then
        Winsock1.Connect strserver, 25
    Else
        lngPort = CLng(Right$(strserver, Len(strserver) - ColonPos))
        strserver = Left$(strserver, ColonPos - 1)
        Winsock1.Connect strserver, lngPort
    End If
    m_State = MAIL_CONNECT    '
    StatusTxt = "试图与服务器连接"
End SubPrivate Sub Winsock1_DataArrival(ByVal bytesTotal As Long)
    Dim strServerResponse   As String
    Dim strResponseCode     As String
    Dim strDataToSend       As String    '
    Const RandString As String = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890_"
    Dim Globalstr As String
    For jd = 1 To 24
        uniquey = Int(Rnd * Len(RandString)) + 1
        Globalstr = Globalstr + Mid(RandString, uniquey, 1)
    Next jd
    strime1 = "Subject:" + Chr(32) + subject + vbCrLf ' Subject of E-Mail
    strime = txtMessage + vbCrLf ' E-mail message body
    strime2 = "X-Mailer:程序太平洋:邮件发送软件V1.0" + vbCrLf ' What program sent the e-mail, customize this
    'MULTI-PART Edit
    strime = "------=_NextPart_" + Globalstr + vbCrLf + "Content-type: text/plain; charset=gb2312" + vbCrLf + vbCrLf + strime
    strime = strime + "------=_NextPart_" + Globalstr + vbCrLf + "Content-type: text/HTML" + vbCrLf + vbCrLf + txtmessage1 + vbCrLf + vbCrLf
    strime = strime + "------=_NextPart_" + Globalstr + "--" + vbCrLf
    strime1 = strime1 + "MIME-Version: 1.0" + vbCrLf + "Content-Type: multipart/alternative; " + vbCrLf + Chr(9) + "boundary=""----=_NextPart_" + Globalstr + """" + vbCrLf + vbCrLf + "This mail is In MIME format. Your mail interface does Not appear To support this format." + vbCrLf + vbCrLf
    strimeall = strime2 + strime1
    Winsock1.GetData strServerResponse
    strResponseCode = Left(strServerResponse, 3)
    If strResponseCode = "250" Or _
       strResponseCode = "220" Or _
       strResponseCode = "354" Or _
       strResponseCode = "334" Or _
       strResponseCode = "235" Then
        Select Case m_State
            Case MAIL_CONNECT
                m_State = MAIL_HELO
                strDataToSend = Trim$(txtfrom)
                'strDataToSend = Left$(strDataToSend, _
                                InStr(1, strDataToSend, "@") - 1)
                 Winsock1.SendData "HELO " & strDataToSend & vbCrLf
                 StatusTxt = "登陆服务器"
            Case MAIL_HELO
                 m_State = MAIL_USER
                 Winsock1.SendData "AUTH LOGIN" & vbCrLf
                 StatusTxt = "正在校验用户名"
            Case MAIL_USER
                 m_State = MAIL_PASS
                 Winsock1.SendData (Base64_Encode(Trim(user.Text))) & vbCrLf
                 StatusTxt = "校验用户密码"
            Case MAIL_PASS
                 m_State = mail_login
                 Winsock1.SendData (Base64_Encode(txtpwa)) & vbCrLf
                 StatusTxt = "发送人邮件地址"
            Case mail_login
                 m_State = mail_from
                 Winsock1.SendData "MAIL FROM:" & Trim$(txtfrom) & vbCrLf
                 StatusTxt = "接收人邮件地址"
            Case mail_from
                 m_State = MAIL_RCPTTO
                 Winsock1.SendData "RCPT TO:" & Trim$(getaddress) & vbCrLf
                 StatusTxt = "邮件发送之中..."
            Case MAIL_RCPTTO
                 m_State = MAIL_DATA
                 Winsock1.SendData "DATA" & vbCrLf
                 StatusTxt = "获取邮件内容"
            Case MAIL_DATA
                m_State = MAIL_DOT
                Winsock1.SendData "From:" & user.Text & " <" & txtfrom & ">" & vbCrLf
                Winsock1.SendData "To:" & toname & " <" & getaddress & ">" & vbCrLf
                Winsock1.SendData strimeall & vbCrLf
                Winsock1.SendData strime & vbCrLf
                Winsock1.SendData "." & vbCrLf
                StatusTxt = "邮件送完毕"
            Case MAIL_DOT
                m_State = MAIL_QUIT
                Winsock1.SendData "QUIT" & vbCrLf
                StatusTxt = "邮件成功发送!!!"
              Case MAIL_QUIT
                 Winsock1.Close
                 StatusTxt = "待命之中..."
         End Select
    Else
         Winsock1.Close
    End If
Debug.Print strServerResponse
End Sub

Answer 6

Private Sub SendEmail(MailServerName As String, FromName As String, FromEmailAddress As String, _
    ToName As String, ToEmailAddress As String, EmailSubject As String, _
    EmailBodyOfMessage As String, Imv As Integer, UserID$, Pw$, SMTPPort%)
    
    Dim MBody$, MTo$, MFrom$, MFormName$, MToName$, MDate$, Msub$, BodyInfo$, AllBody$, EMail$, DateNow$
    Dim MImv$
    Winsock1.LocalPort = 0 ' 必须将端口置0,否则你只能发一次
    
If Winsock1.State = sckClosed Then ' 检测是否处于就绪状态
    DateNow = Format(Date, "Ddd") & ", " & Format(Date, "dd Mmm YYYY") & " " & Format(Time, "hh:mm:ss") & "" & " -0600"
    MFrom = "mail from:" + Chr(32) + FromEmailAddress + vbCrLf '发件人E_Mail地址
    MTo = "rcpt to:" + Chr(32) + ToEmailAddress + vbCrLf '收件人E_Mail地址
    MDate = "Date:" + Chr(32) + DateNow + vbCrLf '发送时间
    
    
    MFormName = "From:" + Chr(32) + FromName + vbCrLf ' 发件人名称
    
    MToName = "To:" + Chr(32) + ToName + vbCrLf ' 收件人名称
    
    Msub = "Subject:" + Chr(32) + EmailSubject + vbCrLf ' 主题
    If Not (Imv = 0 Or Imv = 1 Or Imv = 2) Then '优先级
        Imv = 3
    Else
        If Imv = 0 Then Imv = 5
        If Imv = 1 Then Imv = 3
        If Imv = 2 Then Imv = 1
    End If
    '邮件重要性标志
    MImv = "X-Priority: " & CStr(Imv) & vbCrLf
    
    '加入邮件重要性标志
    BodyInfo = "Content-Type: multipart/alternative;" + vbCrLf & _
            " boundary=" + Chr(34) + "=====YechatYAN=====" + Chr(34) + vbCrLf + MImv & _
            vbCrLf + vbCrLf & _
            "--=====YechatYAN=====" + vbCrLf & _
            "Content-Type: text/html; charset=" + Chr(34) + "GB2312" + Chr(34) + vbCrLf & _
            "Content -Transfer - Encoding: quoted -printable" + vbCrLf + vbCrLf
    MBody = EmailBodyOfMessage & vbCrLf
    '合成邮件内容
    AllBody = BodyInfo & MBody & "--=====YechatYAN=====--" & vbCrLf
    
    EMail = MDate + MFormName + MToName + Msub + AllBody  ' 合成邮件体
    Debug.Print EMail
    Winsock1.Protocol = sckTCPProtocol ' 设置使用TCP协议
    Winsock1.RemoteHost = MailServerName ' SMTP服务器全名
    Winsock1.RemotePort = SMTPPort ' SMTP服务端口
    Labin = "正在连接到SMTP服务器:" & MailServerName & ",请稍后..."
    
    Winsock1.Connect ' 开始连接
    
    If WaitFor("220") Then Exit Sub
    
    Winsock1.SendData ("EHLO " & MailServerName + vbCrLf) '握手
    If WaitFor("250") Then Exit Sub
    Labin = "已成功连接到SMTP服务器:" & MailServerName
    '身份验证
    Winsock1.SendData ("AUTH LOGIN" + vbCrLf) '要求Login
    Labin = "正在验证用户名和密码..."
    If WaitFor("334") Then Exit Sub
    'Base64码
        Winsock1.SendData (Base64encode(UserID) + vbCrLf)
    If WaitFor("334") Then Exit Sub
    
    Winsock1.SendData (Base64encode(Pw) + vbCrLf)
    If WaitFor("235") Then Exit Sub
    Labin = "验证通过."
'验证完成
    
    
'邮件头
    Winsock1.SendData (MFrom)
    Labin = "现在发送邮件..."
    If WaitFor("250") Then Exit Sub
    Winsock1.SendData (MTo)
    If WaitFor("250") Then Exit Sub
    Winsock1.SendData ("data" + vbCrLf)
    If WaitFor("354") Then Exit Sub '返回354表示可以发送邮件正文了'邮件体
    Winsock1.SendData (EMail + vbCrLf)
    Winsock1.SendData ("." + vbCrLf) '邮件结束标志
    If WaitFor("250") Then Exit Sub'断开连接
    Winsock1.SendData ("quit" + vbCrLf)
    If WaitFor("221") Then Exit Sub
    Winsock1.Close
    Labin = "邮件已成功发送."
    If ShowMsg Then
        MsgBox "邮件已成功发送至" & ToEmailAddress & ".", vbInformation, MsgTitle
    End If
Else
    Labin = "端口正忙,请稍后重试." 'Winsock未就绪
End If
   
End Sub
Private Function WaitFor(ResponseCode As String) As Boolean
Dim Tmr!, Start!
    Start = Timer '记录开始时间
    While Len(Response) = 0 '收到SMTP服务器的应答
        Tmr = Timer - Start
        DoEvents ' 必须!让系统不中止对Winsock应答的检测
        If Tmr > MTimeOut Then ' 超时
            If ShowMsg Then
                MsgBox "连接 SMTP 服务器超时,超时秒数:" & MTimeOut & ".", vbExclamation, MsgTitle
            End If
            Labin = "连接 SMTP 服务器超时,超时秒数:" & MTimeOut & "."
            
            WaitFor = True
            Exit Function
        End If
    Wend
    While Left(Response, 3) <> ResponseCode '取出SMTP应答的前三位代码,是否是预期的应答代码
        Tmr = Timer - Start
        DoEvents
        If Tmr > MTimeOut Then
            Select Case Left(Response, 3) '可以加入分类提示信息,现在不加了,我懒 :)
                Case Else
                    '未达到预期后,要与SMTP断开
                    Winsock1.SendData ("quit" + vbCrLf)
                    Winsock1.Close
                    If ShowMsg Then
                        MsgBox "SMTP 服务器错误, 服务器响应代码不正确,响应代码应为:" + ResponseCode _
                        & vbCrLf & " 服务器返回代码为: " + Response, vbCritical, MsgTitle
                    End If
                    Labin = "SMTP 服务器错误, 服务器响应代码不正确,响应代码应为:" + ResponseCode _
                    & vbCrLf & " 服务器返回代码为: " + Response
                    
            End Select
            
            WaitFor = True
            Exit Function
        End If
    Wend
Response = "" '清空用于存储SMTP响应的字串
WaitFor = False '表示此次会话成功完成,如果是True则表示不成功
'Sended = True
End Function

Answer 7

另附：
'编码解码Base64
'Encode和Decode的函数Const sBASE_64_CHARACTERS = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"Function Base64decode(ByVal asContents)
    Dim lsResult
    Dim lnPosition
    Dim lsGroup64, lsGroupBinary
    Dim Char1, Char2, Char3, Char4
    Dim Byte1, Byte2, Byte3
    If Len(asContents) Mod 4 > 0 Then
        asContents = asContents & String(4 - (Len(asContents) Mod 4), " ")
    End If
    lsResult = ""
    
    For lnPosition = 1 To Len(asContents) Step 4
        lsGroupBinary = ""
        lsGroup64 = Mid(asContents, lnPosition, 4)
        Char1 = InStr(sBASE_64_CHARACTERS, Mid(lsGroup64, 1, 1)) - 1
        Char2 = InStr(sBASE_64_CHARACTERS, Mid(lsGroup64, 2, 1)) - 1
        Char3 = InStr(sBASE_64_CHARACTERS, Mid(lsGroup64, 3, 1)) - 1
        Char4 = InStr(sBASE_64_CHARACTERS, Mid(lsGroup64, 4, 1)) - 1
        Byte1 = Chr(((Char2 And 48) \ 16) Or (Char1 * 4) And &HFF)
        Byte2 = lsGroupBinary & Chr(((Char3 And 60) \ 4) Or (Char2 * 16) And &HFF)
        Byte3 = Chr((((Char3 And 3) * 64) And &HFF) Or (Char4 And 63))
        lsGroupBinary = Byte1 & Byte2 & Byte3
        lsResult = lsResult + lsGroupBinary
    Next
    Base64decode = lsResult
End Function
Function Base64encode(ByVal asContents)
    Dim lnPosition
    Dim lsResult
    Dim Char1
    Dim Char2
    Dim Char3
    Dim Char4
    Dim Byte1
    Dim Byte2
    Dim Byte3
    Dim SaveBits1
    Dim SaveBits2
    Dim lsGroupBinary
    Dim lsGroup64
    
    'If Len(asContents) Mod 3 > 0 Then asContents = asContents & String(3 - (Len(asContents) Mod 3), " ")
    
    lsResult = ""
    
    For lnPosition = 1 To Len(asContents) Step 3
        lsGroup64 = ""
        lsGroupBinary = Mid(asContents, lnPosition, 3)
        
        Byte1 = Asc(Mid(lsGroupBinary, 1, 1)): SaveBits1 = Byte1 And 3
        If Len(Mid(asContents, lnPosition + 1, 1)) <> 0 Then
            Byte2 = Asc(Mid(lsGroupBinary, 2, 1))
        Else
            Byte2 = 0
        End If
            SaveBits2 = Byte2 And 15
        If Len(Mid(asContents, lnPosition + 2, 1)) <> 0 Then
            Byte3 = Asc(Mid(lsGroupBinary, 3, 1))
        Else
            Byte3 = 0
        End If
        
        Char1 = Mid(sBASE_64_CHARACTERS, ((Byte1 And 252) \ 4) + 1, 1)
        Char2 = Mid(sBASE_64_CHARACTERS, (((Byte2 And 240) \ 16) Or (SaveBits1 * 16) And &HFF) + 1, 1)
        
        If Not (SaveBits2 = 0 And Byte2 = 0) Then
            Char3 = Mid(sBASE_64_CHARACTERS, (((Byte3 And 192) \ 64) Or (SaveBits2 * 4) And &HFF) + 1, 1)
            Char4 = Mid(sBASE_64_CHARACTERS, (Byte3 And 63) + 1, 1)
        Else
            Char3 = "="
            Char4 = "="
        End If
        
        
        lsGroup64 = Char1 & Char2 & Char3 & Char4
        
        lsResult = lsResult + lsGroup64
    Next
    
    Base64encode = lsResult
End Function

Answer 8

另外：以上代码只能发纯文本和HTML邮件。IMEM格式的邮件难搞，不想搞了。
实际上以上代码以HTML格式发邮件，对于没有HTML标记的邮件体，当然就成了纯文本了。
也可以用HTML标记，或直接把邮件体换为HTML文件内容。
还有，以上代码不支持附件。
CDO对象方便，功能强，不过只能在安装了IIS和SMTP服务的机器上用。
CDO主要用于ASP，而VB用CDO太奢侈了，因为不可能每个客户端都装IIS。现在大的网站的MAIL SERVER一般都用了EHLO，也就是增强密码验证，而有些单位内部局域网还是用的以前的HELO，发邮件的时候不用身份校验。所以你上边的代码可以通过SINA NETEASE等的SMTP SERVER发邮件，而不能在单位内部的SMTP SERVER发。因为你单位的SMTP SERVER不认识EHLO这个命令。如果情况如我所说，那我就得祝贺你了，因为你可以匿名向某个PLMM发低级笑话了,甚至可以以别人的名义向PLMM发黄段子。
 
:)

Answer 9

各位高手，请教一个问题：
在下面的代码里，为何执行不到（StatusTxt = "待命之中..."）这句，
即我想得到这句回应：221 21cn.com closing connection.总得不到，求教高手，谢谢！！！！
Private Enum SMTP_State
    MAIL_CONNECT
    MAIL_HELO
    mail_from
    MAIL_RCPTTO
    MAIL_DATA
    MAIL_DOT
    MAIL_QUIT
    MAIL_USER
    MAIL_PASS
    mail_login
End Enum
Private m_State As SMTP_State
Private m_strEncodedFiles As String
Private Function Base64_Encode(strSource) As String 'base6加密算法
    Const BASE64_TABLE As String = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
    Dim strTempLine As String
    Dim j As Integer
    For j = 1 To (Len(strSource) - Len(strSource) Mod 3) Step 3
        strTempLine = strTempLine + Mid(BASE64_TABLE, (Asc(Mid(strSource, j, 1)) \ 4) + 1, 1)
        strTempLine = strTempLine + Mid(BASE64_TABLE, ((Asc(Mid(strSource, j, 1)) Mod 4) * 16 _
                      + Asc(Mid(strSource, j + 1, 1)) \ 16) + 1, 1)
        strTempLine = strTempLine + Mid(BASE64_TABLE, ((Asc(Mid(strSource, j + 1, 1)) Mod 16) * 4 _
                      + Asc(Mid(strSource, j + 2, 1)) \ 64) + 1, 1)
        strTempLine = strTempLine + Mid(BASE64_TABLE, (Asc(Mid(strSource, j + 2, 1)) Mod 64) + 1, 1)
    Next j
    If Not (Len(strSource) Mod 3) = 0 Then
         If (Len(strSource) Mod 3) = 2 Then
            strTempLine = strTempLine + Mid(BASE64_TABLE, (Asc(Mid(strSource, j, 1)) \ 4) + 1, 1)
            strTempLine = strTempLine + Mid(BASE64_TABLE, (Asc(Mid(strSource, j, 1)) Mod 4) * 16 _
                      + Asc(Mid(strSource, j + 1, 1)) \ 16 + 1, 1)
             strTempLine = strTempLine + Mid(BASE64_TABLE, (Asc(Mid(strSource, j + 1, 1)) Mod 16) * 4 + 1, 1)
            strTempLine = strTempLine & "="
        ElseIf (Len(strSource) Mod 3) = 1 Then
            strTempLine = strTempLine + Mid(BASE64_TABLE, Asc(Mid(strSource, j, 1)) \ 4 + 1, 1)
            strTempLine = strTempLine + Mid(BASE64_TABLE, (Asc(Mid(strSource, j, 1)) Mod 4) * 16 + 1, 1)
             strTempLine = strTempLine & "=="
        End If
     End If
    Base64_Encode = strTempLine
End Function
Private Sub cmdExit_Click()
Unload Me
End Sub
Private Sub CmdSend_Click()
    Winsock1.Close
    Winsock1.LocalPort = 0
    strserver = txtserver
    ColonPos = InStr(strserver, ":")
    If ColonPos = 0 Then
        Winsock1.Connect strserver, 25
    Else
        lngPort = CLng(Right$(strserver, Len(strserver) - ColonPos))
        strserver = Left$(strserver, ColonPos - 1)
        Winsock1.Connect strserver, lngPort
    End If
    m_State = MAIL_CONNECT    '
    StatusTxt = "试图与服务器连接"
End SubPrivate Sub Winsock1_DataArrival(ByVal bytesTotal As Long)
    Dim strServerResponse   As String
    Dim strResponseCode     As String
    Dim strDataToSend       As String    '
    Const RandString As String = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890_"
    Dim Globalstr As String
    For jd = 1 To 24
        uniquey = Int(Rnd * Len(RandString)) + 1
        Globalstr = Globalstr + Mid(RandString, uniquey, 1)
    Next jd
    strime1 = "Subject:" + Chr(32) + subject + vbCrLf ' Subject of E-Mail
    strime = txtMessage + vbCrLf ' E-mail message body
    strime2 = "X-Mailer:程序太平洋:邮件发送软件V1.0" + vbCrLf ' What program sent the e-mail, customize this
    'MULTI-PART Edit
    strime = "------=_NextPart_" + Globalstr + vbCrLf + "Content-type: text/plain; charset=gb2312" + vbCrLf + vbCrLf + strime
    strime = strime + "------=_NextPart_" + Globalstr + vbCrLf + "Content-type: text/HTML" + vbCrLf + vbCrLf + txtmessage1 + vbCrLf + vbCrLf
    strime = strime + "------=_NextPart_" + Globalstr + "--" + vbCrLf
    strime1 = strime1 + "MIME-Version: 1.0" + vbCrLf + "Content-Type: multipart/alternative; " + vbCrLf + Chr(9) + "boundary=""----=_NextPart_" + Globalstr + """" + vbCrLf + vbCrLf + "This mail is In MIME format. Your mail interface does Not appear To support this format." + vbCrLf + vbCrLf
    strimeall = strime2 + strime1
    Winsock1.GetData strServerResponse
    strResponseCode = Left(strServerResponse, 3)
    If strResponseCode = "250" Or _
       strResponseCode = "220" Or _
       strResponseCode = "354" Or _
       strResponseCode = "334" Or _
       strResponseCode = "235" Then
        Select Case m_State
            Case MAIL_CONNECT
                m_State = MAIL_HELO
                strDataToSend = Trim$(txtfrom)
                'strDataToSend = Left$(strDataToSend, _
                                InStr(1, strDataToSend, "@") - 1)
                 Winsock1.SendData "HELO " & strDataToSend & vbCrLf
                 StatusTxt = "登陆服务器"
            Case MAIL_HELO
                 m_State = MAIL_USER
                 Winsock1.SendData "AUTH LOGIN" & vbCrLf
                 StatusTxt = "正在校验用户名"
            Case MAIL_USER
                 m_State = MAIL_PASS
                 Winsock1.SendData (Base64_Encode(Trim(user.Text))) & vbCrLf
                 StatusTxt = "校验用户密码"
            Case MAIL_PASS
                 m_State = mail_login
                 Winsock1.SendData (Base64_Encode(txtpwa)) & vbCrLf
                 StatusTxt = "发送人邮件地址"
            Case mail_login
                 m_State = mail_from
                 Winsock1.SendData "MAIL FROM:" & Trim$(txtfrom) & vbCrLf
                 StatusTxt = "接收人邮件地址"
            Case mail_from
                 m_State = MAIL_RCPTTO
                 Winsock1.SendData "RCPT TO:" & Trim$(getaddress) & vbCrLf
                 StatusTxt = "邮件发送之中..."
            Case MAIL_RCPTTO
                 m_State = MAIL_DATA
                 Winsock1.SendData "DATA" & vbCrLf
                 StatusTxt = "获取邮件内容"
            Case MAIL_DATA
                m_State = MAIL_DOT
                Winsock1.SendData "From:" & user.Text & " <" & txtfrom & ">" & vbCrLf
                Winsock1.SendData "To:" & toname & " <" & getaddress & ">" & vbCrLf
                Winsock1.SendData strimeall & vbCrLf
                Winsock1.SendData strime & vbCrLf
                Winsock1.SendData "." & vbCrLf
                StatusTxt = "邮件送完毕"
            Case MAIL_DOT
                m_State = MAIL_QUIT
                Winsock1.SendData "QUIT" & vbCrLf
                StatusTxt = "邮件成功发送!!!"
              Case MAIL_QUIT
                 Winsock1.Close
                 StatusTxt = "待命之中..."
         End Select
    Else
         Winsock1.Close
    End If
Debug.Print strServerResponse
End Sub