急，求助！有关邮件传输入的问题！

Dim DataStr As String
Dim Start As Single
Dim WaitTime As Single'  发送邮件
Private Sub cmdSend_Click()
    Dim FromStr As String
    Dim ToStr As String
    Dim SubjectStr As String
    Dim DateStr As String
    Dim MailTypeStr As String
    Dim MailHeaderStr As String
    Dim MailBodyStr As String
    Dim blnOK As Boolean

    If Winsock1.State = sckClosed Then
        ' 使用 TCP Protocol
        Winsock1.Protocol = sckTCPProtocol

        ' 设置邮件服务器 IP 地址
        Winsock1.RemoteHost = txtServer.Text

        ' 设置 SMTP 端口为 25
        Winsock1.RemotePort = 25

        ' 发件端尝试连接到邮件服务器
        Winsock1.Connect

        ' 等候邮件服务器返回 220 Ready for Mail 信息
        blnOK = WaitforResponse("220")    ' Ready for Mail

        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

        ' 发件端发出 HELO 指令
        Winsock1.SendData "HELO " & txtServer.Text & vbCrLf

        ' 等候邮件服务器返回 250 OK 信息
        blnOK = WaitforResponse("250")   ' OK

        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

        ' 发件端发出 MAIL FROM: 指令代表发件人 E-Mail 地址
        Winsock1.SendData "MAIL FROM: " & Trim(txtFromAddress.Text) & vbCrLf        StatusBar1.Panels(1).Text = "Status: Sending Message"
        StatusBar1.Refresh

        ' 等候邮件服务器返回 250 OK 信息
        blnOK = WaitforResponse("250")   ' OK        If Not blnOK Then
            StatusBar1.Panels(1).Text = "Status: Connection Fail"
            StatusBar1.Refresh
            Exit Sub
        End If        ' 发件端发出 RCPT TO: 指令代表收件人 E-Mail 地址
        Winsock1.SendData "RCPT TO: " & Trim(txtToAddress.Text) & vbCrLf

        ' 等候邮件服务器返回 250 OK 信息
        blnOK = WaitforResponse("250")   ' OK

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

        ' 发件端发出 DATA 指令代表开始传送 E-Mail
        Winsock1.SendData "DATA" & vbCrLf

        ' 等候邮件服务器返回 354 Start Mail Input 信息
        blnOK = WaitforResponse("354")   ' Start Mail Input

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

        ' E-Mail Header (标题) 部分
        FromStr = "From: """ & txtFromName.Text & """ <" & Trim(txtFromAddress.Text) & ">" & vbCrLf
        ToStr = "To: """ & txtToName.Text & """ <" & Trim(txtToAddress.Text) & ">" & vbCrLf
        SubjectStr = "Subject: " & txtSubject.Text & vbCrLf
        DateStr = "Date: " & Format(Date, "Ddd") & ", " & Format(Date, "dd Mmm YYYY") & " " & Format(Time, "hh:mm:ss") & " +0800" & vbCrLf
        MailTypeStr = "MIME-Version: 1.0" & vbCrLf & "X-Mailer: Internet Mail Service (5.5.2448.0)" & vbCrLf
        MailHeaderStr = FromStr & ToStr & SubjectStr & DateStr & MailTypeStr

        ' 发件端传送 E-Mail Header (标题) 部分
        Winsock1.SendData MailHeaderStr & vbCrLf

        ' E-Mail Body (内容) 部分
        MailBodyStr = txtMessage.Text & vbCrLf

        ' 发件端传送 E-Mail Body (内容) 部分
        Winsock1.SendData MailBodyStr & vbCrLf

        ' E-Mail 以句号 (.) 作为结尾
        Winsock1.SendData vbCrLf & "." & vbCrLf

        ' 等候邮件服务器返回 250 OK 信息
        blnOK = WaitforResponse("250")   ' OK

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

        ' 发件端发出 QUIT 指令代表关闭 TCP 连接
        Winsock1.SendData "QUIT" & vbCrLf

        StatusBar1.Panels(1).Text = "Status: Disconnecting"
        StatusBar1.Refresh

        ' 等候邮件服务器返回 221 Close Connection 信息
        blnOK = WaitforResponse("221")   ' Close Connection

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

        ' 关闭 Winsock
        Winsock1.Close

        StatusBar1.Panels(1).Text = "Status: Mail Sent"
        StatusBar1.Refresh
    End If
End Sub'  在DataArrival使用GetData方法获得返回信息
Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)
    ' 邮件服务器返回信息, 其中:
    '   220 代表 Ready for Mail
    '   221 代表 Close Connection
    '   250 代表 OK
    '   354 代表 Start Mail Input
    Winsock1.GetData DataStr
End Sub'  定时通过邮件服务器返回信息判断邮件发送状态
Private Function WaitforResponse(ResponseCode As String) As Boolean
    Start = Timer

    ' SMTP 错误: 超时
    Do While Len(DataStr) = 0
        WaitTime = Timer - Start
        DoEvents
        If WaitTime > 50 Then
            MsgBox "SMTP Error: Time Out.", vbCritical
            WaitforResponse = False
            Exit Function
        End If
    Loop

    ' Winsock 错误
    Do While Left(DataStr, 3) <> ResponseCode
        DoEvents
        If WaitTime > 50 Then
            MsgBox "SMTP Error: " & ResponseCode & " " & DataStr, vbCritical
            WaitforResponse = False
            Exit Function
        End If
    Loop

    DataStr = ""
    WaitforResponse = True
End Function'  退出程序
Private Sub cmdExit_Click()
    '  关闭TCP连接
    If Winsock1.State <> sckClosed Then
        Winsock1.Close
    End If
    End
End Sub
'收
'form:
Private Enum POP3States
    POP3_Connect
    POP3_USER
    POP3_PASS
    POP3_STAT
    POP3_RETR
    POP3_DELE
    POP3_QUIT
End EnumPrivate m_State As POP3States
Private m_oMessage As CMessage
Private m_colMessages As New CMessagesPrivate Sub cmdCheckMail_Click()
    '  检查文本区是否为空
    For Each c In Controls
        If TypeOf c Is TextBox And c.Name <> "txtBody" Then
            If Len(c.Text) = 0 Then
                MsgBox c.Name & " can't be empty", vbCritical
                Exit Sub
            End If
        End If
    Next

    '  改变连接状态
    m_State = POP3_Connect
    '  如果有其他连接则关闭
    Winsock1.Close

    Winsock1.LocalPort = 0
    '  连接服务器端口
    Winsock1.Connect txtHost, 110
End SubPrivate Sub cmdDel_Click()
    Unload Me
End Sub'  单击邮件的列表中的项目查看邮件内容
Private Sub lvMessages_ItemClick(ByVal Item As ComctlLib.ListItem)
    txtBody = m_colMessages(Item.Key).MessageBody
End SubPrivate Sub Winsock1_DataArrival(ByVal bytesTotal As Long)
    Dim strData As String

    Static intMessages As Integer
    Static intCurrentMessage As Integer
    Static strBuffer As String

    '  读取返回信息
    Winsock1.GetData strData
    Debug.Print strData

    If Left$(strData, 1) = "+" Or m_State = POP3_RETR Then
        '  根据返回信息进行操作
        Select Case m_State
            Case POP3_Connect
                intMessages = 0
                m_State = POP3_USER
                '  发送USER命令
                Winsock1.SendData "USER " & txtUserName & vbCrLf
            Case POP3_USER
                m_State = POP3_PASS
                '  发送PASS命令
                Winsock1.SendData "PASS " & txtPassword & vbCrLf
            Case POP3_PASS
                m_State = POP3_STAT
                '发送STAT命令
                Winsock1.SendData "STAT" & vbCrLf
            Case POP3_STAT
                '  获得邮件数量
                intMessages = CInt(Mid$(strData, 5, InStr(5, strData, " ") - 5))
                If intMessages > 0 Then
                    m_State = POP3_RETR
                    intCurrentMessage = intCurrentMessage + 1
                    '  发送RETR命令
                    Winsock1.SendData "RETR 1" & vbCrLf
                Else
                    '  发送QUIT命令
                    m_State = POP3_QUIT
                    Winsock1.SendData "QUIT" & vbCrLf
                    MsgBox "You have not mail.", vbInformation
                End If
            Case POP3_RETR
                '  收取邮件
                strBuffer = strBuffer & strData
                If InStr(1, strBuffer, vbLf & "." & vbCrLf) Then
                    '  确定消息主体
                    strBuffer = Mid$(strBuffer, InStr(1, strBuffer, vbCrLf) + 2)
                    strBuffer = Left$(strBuffer, Len(strBuffer) - 3)

                    '  将消息添加到colMessages中
                    Set m_oMessage = New CMessage
                    m_oMessage.CreateFromText strBuffer
                    m_colMessages.Add m_oMessage, m_oMessage.MessageID
                    Set m_oMessage = Nothing

                    strBuffer = ""
                    '  接收下一条
                    If intCurrentMessage = intMessages Then
                        m_State = POP3_QUIT
                        Winsock1.SendData "QUIT" & vbCrLf
                    Else
                        intCurrentMessage = intCurrentMessage + 1
                        m_State = POP3_RETR
                        Winsock1.SendData "RETR " & CStr(intCurrentMessage) & vbCrLf
                    End If
                End If
            Case POP3_QUIT
                '  退出Socket连接
                Winsock1.Close
                '  列出收到的邮件
                Call ListMessages
        End Select
    Else

        Winsock1.Close
        MsgBox "POP3 Error: " & strData, vbExclamation, "POP3 Error"
    End If
End Sub'  如果Socket连接出错
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 "Winsock Error: #" & Number & vbCrLf & Description
End Sub
'  列出收到的邮件
Private Sub ListMessages()
    Dim oMes As CMessage
    Dim lvItem As ListItem

    For Each oMes In m_colMessages
        Set lvItem = lvMessages.ListItems.Add
        lvItem.Key = oMes.MessageID
        lvItem.Text = oMes.From
        lvItem.SubItems(1) = oMes.Subject
        lvItem.SubItems(2) = oMes.SendDate
        lvItem.SubItems(3) = oMes.Size
    Next
End Sub
'类模块：  CMessage
Private m_strReturnPath      As String
Private m_strReceived        As String
Private m_strSendDate        As String
Private m_strMessageID       As String
Private m_strMessageTo       As String
Private m_strFrom            As String
Private m_strSubject         As String
Private m_strReplyTo         As String
Private m_strSender          As String
Private m_strCC              As String
Private m_strBCC             As String
Private m_strInReplyTo       As String
Private m_strReferences      As String
Private m_strKeywords        As String
Private m_strComments        As String
Private m_strEncrypted       As String
Private m_strMessageText     As String
Private m_strMessageBody     As String
Private m_strHeaders         As String
Private m_lSize              As LongPublic Sub CreateFromText(strMessage As String)    Dim intPosA         As Integer
    Dim vHeaders        As Variant
    Dim vField          As Variant
    Dim strHeader       As String
    Dim strHeaderName   As String
    Dim strHeaderValue  As String

    intPosA = InStr(1, strMessage, vbCrLf & vbCrLf)
    If intPosA Then
        m_strHeaders = Left$(strMessage, intPosA - 1)
        m_strMessageBody = Right$(strMessage, Len(strMessage) - intPosA - 3)
        m_strMessageText = strMessage
    Else
        Err.Raise vbObjectError + 512 + 101, "CMessage.CreateFromText", _
                    "Invalid message format"
        Exit Sub
    End If

    vHeaders = Split(m_strHeaders, vbCrLf)
    For Each vField In vHeaders
        strHeader = CStr(vField)
        intPosA = InStr(1, strHeader, ":")
        If intPosA Then
            strHeaderName = LCase(Left$(strHeader, intPosA - 1))
        Else
            strHeaderName = ""
        End If
        strHeaderValue = Trim$(Right$(strHeader, Len(strHeader) - intPosA))
        Select Case strHeaderName
            Case "return-path"
                m_strReturnPath = strHeaderValue
            Case "received"
                m_strReceived = strHeaderValue
            Case "from"
                m_strFrom = strHeaderValue
            Case "sender"
                m_strSender = strHeaderValue
            Case "reply-to"
                m_strReplyTo = strHeaderValue
            Case "to"
                m_strMessageTo = strHeaderValue
            Case "cc"
                m_strCC = strHeaderValue
            Case "bcc"
                m_strBCC = strHeaderValue
            Case "message-id"
                m_strMessageID = strHeaderValue
            Case "in-reply-to"
                m_strInReplyTo = strHeaderValue
            Case "references"
                m_strReferences = strHeaderValue
            Case "keywords"
                m_strKeywords = strHeaderValue
            Case "subject"
                m_strSubject = strHeaderValue
            Case "comments"
                m_strComments = strHeaderValue
            Case "encrypted"
                m_strEncrypted = strHeaderValue
            Case "date"
                m_strSendDate = strHeaderValue
        End Select
    Next
    If m_strMessageID = "" Then
       m_strMessageID = m_strSendDate
    End If
End Sub
Public Function CombineMessage() As StringEnd Function
Public Property Let Headers(ByVal vData As String)
    m_strHeaders = vData
End Property
Public Property Get Headers() As String
    Headers = m_strHeaders
End PropertyPublic Property Let MessageBody(ByVal vData As String)
    m_strMessageBody = vData
End PropertyPublic Property Get MessageBody() As String
    MessageBody = m_strMessageBody
End PropertyPublic Property Let MessageText(ByVal vData As String)
    m_strMessageText = vData
End PropertyPublic Property Get MessageText() As String
    MessageText = m_strMessageText
End PropertyPublic Property Let Encrypted(ByVal vData As String)
    m_strEncrypted = vData
End PropertyPublic Property Get Encrypted() As String
    Encrypted = m_strEncrypted
End PropertyPublic Property Let Comments(ByVal vData As String)
    m_strComments = vData
End PropertyPublic Property Get Comments() As String
    Comments = m_strComments
End PropertyPublic Property Let Keywords(ByVal vData As String)
    m_strKeywords = vData
End PropertyPublic Property Get Keywords() As String
    Keywords = m_strKeywords
End PropertyPublic Property Let References(ByVal vData As String)
    m_strReferences = vData
End PropertyPublic Property Get References() As String
    References = m_strReferences
End PropertyPublic Property Let InReplyTo(ByVal vData As String)
    m_strInReplyTo = vData
End PropertyPublic Property Get InReplyTo() As String
    InReplyTo = m_strInReplyTo
End PropertyPublic Property Let BCC(ByVal vData As String)
    m_strBCC = vData
End PropertyPublic Property Get BCC() As String
    BCC = m_strBCC
End PropertyPublic Property Let CC(ByVal vData As String)
    m_strCC = vData
End PropertyPublic Property Get CC() As String
    CC = m_strCC
End PropertyPublic Property Let Sender(ByVal vData As String)
    m_strSender = vData
End PropertyPublic Property Get Sender() As String
    Sender = m_strSender
End PropertyPublic Property Let ReplyTo(ByVal vData As String)
    m_strReplyTo = vData
End PropertyPublic Property Get ReplyTo() As String
    ReplyTo = m_strReplyTo
End PropertyPublic Property Let Subject(ByVal vData As String)
    m_strSubject = vData
End PropertyPublic Property Get Subject() As String
    Subject = m_strSubject
End PropertyPublic Property Let From(ByVal vData As String)
    m_strFrom = vData
End PropertyPublic Property Get From() As String
    From = m_strFrom
End PropertyPublic Property Let MessageTo(ByVal vData As String)
    m_strMessageTo = vData
End PropertyPublic Property Get MessageTo() As String
    MessageTo = m_strMessageTo
End PropertyPublic Property Let MessageID(ByVal vData As String)
    m_strMessageID = vData
End PropertyPublic Property Get MessageID() As String
    MessageID = m_strMessageID
End PropertyPublic Property Let SendDate(ByVal vData As String)
    m_strSendDate = vData
End PropertyPublic Property Get SendDate() As String
    SendDate = m_strSendDate
End PropertyPublic Property Let Received(ByVal vData As String)
    m_strReceived = vData
End PropertyPublic Property Get Received() As String
    Received = m_strReceived
End PropertyPublic Property Let ReturnPath(ByVal vData As String)
    m_strReturnPath = vData
End PropertyPublic Property Get ReturnPath() As String
    ReturnPath = m_strReturnPath
End PropertyPublic Property Get Size() As Long
    Size = Len(m_strMessageText)
End Property
’类模块：  CMessages
Private mCol As CollectionPublic Sub Add(oMessage As CMessage, Optional sKey As String)

    If Len(sKey) = 0 Then
        mCol.Add oMessage
    Else
        mCol.Add oMessage, sKey
    End IfEnd SubPublic Property Get Item(vntIndexKey As Variant) As CMessage
  Set Item = mCol(vntIndexKey)
End PropertyPublic Property Get Count() As Long
    Count = mCol.Count
End PropertyPublic Sub Remove(vntIndexKey As Variant)
    mCol.Remove vntIndexKey
End SubPublic Property Get NewEnum() As IUnknown
    Set NewEnum = mCol.[_NewEnum]
End PropertyPrivate Sub Class_Initialize()
    Set mCol = New Collection
End SubPrivate Sub Class_Terminate()
    Set mCol = Nothing
End Sub

调试易

急，求助！有关邮件传输入的问题！

解决方案 »