非常急的问题 发送邮件问题 解决立马送我所有的分

我想用winsock实现发送邮件   请给我贴段完整代码或URL     可行  立马给分
      要求  越简单越快的越好

解决方案 »

  1.   

    N年前写的代码了.希望能帮到你.'=====  part1Public 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
    Dim m_State As SMTP_State
    Dim filebyte() As Byte
    Dim m_strEncodedFiles() As String, m_strTmpEncodedFiles() As String
    Dim lng_LocalPort As Long
    Dim str_SMTPAddress As String
    Dim strMailTO As String
    Dim isBreak As Boolean
    Dim isMultiple As BooleanPrivate Function Base64_EncodeBin(byteSource) As String
        Dim BASE64_TABLE(1 To 64) As Byte    '用Byte数组保存编码表，可以省掉计算Asc值这一步
        Dim j As Double
        Dim m As Double
        Dim n As Double
        Dim num As Double
        Dim intPos As Double
        Dim BASE64_STR As String
        Dim a() As Byte
        
        BASE64_STR = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
        
        For j = 1 To 64
            BASE64_TABLE(j) = Asc(Mid(BASE64_STR, j, 1))
        Next
        
        n = (UBound(byteSource) - UBound(byteSource) Mod 3)
        num = (n \ 3) * 4
        
        m = 0
        intPos = 0
        
        ReDim a(1 To num) As Byte
        
        For j = 1 To n Step 3
            
            m = m + 1
            a(m) = BASE64_TABLE((byteSource(j) \ 4) + 1)
            
            m = m + 1
            a(m) = BASE64_TABLE(((byteSource(j) Mod 4) * 16 + byteSource(j + 1) \ 16) + 1)
            
            m = m + 1
            a(m) = BASE64_TABLE(((byteSource(j + 1) Mod 16) * 4 + byteSource(j + 2) \ 64) + 1)
            
            m = m + 1
            a(m) = BASE64_TABLE((byteSource(j + 2) Mod 64) + 1)
            
            intPos = intPos + 4        If (intPos Mod 76) = 0 Then
               num = num + 2
               ReDim Preserve a(1 To num) As Byte
               m = m + 1
               a(m) = Asc(vbCr)
               m = m + 1
               a(m) = Asc(vbLf)
            End If
            
            DoEvents
            
        Next j
        
        If Not (UBound(byteSource) Mod 3) = 0 Then
             If (UBound(byteSource) Mod 3) = 2 Then
                num = num + 4
                ReDim Preserve a(1 To num) As Byte
                m = m + 1
                a(m) = BASE64_TABLE((byteSource(j) \ 4) + 1)
                If m Mod 76 = 0 Then
                    num = num + 2
                    ReDim Preserve a(1 To num) As Byte
                    m = m + 1
                    a(m) = Asc(vbCr)
                    m = m + 1
                    a(m) = Asc(vbLf)
                End If
                m = m + 1
                a(m) = BASE64_TABLE((byteSource(j) Mod 4) * 16 + byteSource(j + 1) \ 16 + 1)
                If m Mod 76 = 0 Then
                    num = num + 2
                    ReDim Preserve a(1 To num) As Byte
                    m = m + 1
                    a(m) = Asc(vbCr)
                    m = m + 1
                    a(m) = Asc(vbLf)
                End If
                m = m + 1
                a(m) = BASE64_TABLE((byteSource(j + 1) Mod 16) * 4 + 1)
                If m Mod 76 = 0 Then
                    num = num + 2
                    ReDim Preserve a(1 To num) As Byte
                    m = m + 1
                    a(m) = Asc(vbCr)
                    m = m + 1
                    a(m) = Asc(vbLf)
                End If
                m = m + 1
                a(m) = Asc("=")
             ElseIf (UBound(byteSource) Mod 3) = 1 Then
                num = num + 3
                ReDim Preserve a(1 To num) As Byte
                m = m + 1
                a(m) = BASE64_TABLE(byteSource(j) \ 4 + 1)
                If m Mod 76 = 0 Then
                    num = num + 2
                    ReDim Preserve a(1 To num) As Byte
                    m = m + 1
                    a(m) = Asc(vbCr)
                    m = m + 1
                    a(m) = Asc(vbLf)
                End If
                m = m + 1
                a(m) = BASE64_TABLE((byteSource(j) Mod 4) * 16 + 1)
                If m Mod 76 = 0 Then
                    num = num + 2
                    ReDim Preserve a(1 To num) As Byte
                    m = m + 1
                    a(m) = Asc(vbCr)
                    m = m + 1
                    a(m) = Asc(vbLf)
                End If
                m = m + 1
                a(m) = Asc("==")
             End If
        End If
        ReDim Preserve a(1 To m) As Byte '去掉有可能多出的空格
        
        Base64_EncodeBin = StrConv(a, vbUnicode)
        
    End Function
    Private Function Base64_Encode(strSource) As String 'base6加密算法
        Const BASE64_TABLE As String = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
        Dim strTempLine As String
        Dim j As Long
        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 FunctionPrivate Sub Command1_Click()
        Dim ColonPos As Long
        
        If Trim(Text1.Text) = "" Then MsgBox "收件人不能为空!", vbExclamation, "错误": Text1.SetFocus: Exit Sub
        
        SendWinsock.Close
        SendWinsock.LocalPort = 0
        ColonPos = InStr(str_SMTPServerName, ":")
        If ColonPos = 0 Then
            SendWinsock.Connect str_SMTPServerName, 25
        Else
            lng_LocalPort = CLng(Right$(str_SMTPServerName, Len(str_SMTPServerName) - ColonPos))
            str_SMTPAddress = Left$(str_SMTPServerName, ColonPos - 1)
            SendWinsock.Connect str_SMTPAddress, lngPort
        End If
        m_State = MAIL_CONNECT    '
        
        StatusBar1.SimpleText = "试图与服务器连接"
    End SubPrivate Sub Command2_Click()
    SendWinsock.Close
    isBreak = True
    Unload Me
    End Sub
      

  2.   

    '=== part2
    Private Sub Command3_Click()
    Dim str_TempFiles() As String
    Dim str_TmpStrings As String, str_TmpPath As String
    Dim afileSize As Double
    Dim fileIdx As Long
    On Error Resume Next
    Erase filebyteCommand1.Enabled = False
    Command3.Enabled = FalseCommonDialog1.FileName = ""
    CommonDialog1.DialogTitle = "添加附件"CommonDialog1.Flags = cdlOFNAllowMultiselect Or cdlOFNExplorer Or cdlOFNFileMustExist Or cdlOFNHideReadOnly Or cdlOFNPathMustExistCommonDialog1.Filter = "所有文件(*.*)|*.*|"
    CommonDialog1.ShowOpenIf CommonDialog1.FileName <> "" Then
       
       StatusBar1.SimpleText = "正在加载附件,可能会花费一些时间.请稍侯..."
       
       fileAttach.Clear
       
       Me.MousePointer = 11
       
       If InStr(CommonDialog1.FileName, Chr(0)) <> 0 Then
          str_TmpStrings = Right(CommonDialog1.FileName, Len(CommonDialog1.FileName) - InStr(CommonDialog1.FileName, Chr(0)))
          str_TmpPath = Left(CommonDialog1.FileName, InStr(CommonDialog1.FileName, Chr(0)) - 1)
          str_TempFiles = Split(str_TmpStrings, Chr(0), -1, vbBinaryCompare)
          
          str_TmpPath = IIf(Right(str_TmpPath, 1) = "\", str_TmpPath, str_TmpPath & "\")
          
          ReDim m_strEncodedFiles(UBound(str_TempFiles))
          
          For fileIdx = 0 To UBound(str_TempFiles)
              If Dir(str_TmpPath & str_TempFiles(fileIdx)) <> "" Then
                 If FileLen(str_TmpPath & str_TempFiles(fileIdx)) > 5242880 Then
                    If MsgBox("附件超过5MB,可能会花费很多时间." & vbCrLf & vbCrLf & "确定要继续吗?", vbQuestion + vbYesNo + vbDefaultButton2, "提示") = vbNo Then
                       Command1.Enabled = True
                       Exit Sub
                    End If
                 End If
                 Open str_TmpPath & str_TempFiles(fileIdx) For Binary Access Read As #1
                      afileSize = LOF(1)
                      ReDim filebyte(1 To afileSize)
                      Get #1, , filebyte
                 Close #1
             
                 m_strEncodedFiles(fileIdx) = Base64_EncodeBin(filebyte)
                 fileAttach.AddItem str_TempFiles(fileIdx)
              End If
          
          Next
          
          If fileAttach.ListCount > 0 Then
             isMultiple = True
             fileAttach.Text = fileAttach.List(0)
          Else
             isMultiple = False
          End If
       
       Else
          If Dir(CommonDialog1.FileName) <> "" Then
             If FileLen(CommonDialog1.FileName) > 5242880 Then
                If MsgBox("附件超过5MB,可能会花费很多时间." & vbCrLf & vbCrLf & "确定要继续吗?", vbQuestion + vbYesNo + vbDefaultButton2, "提示") = vbNo Then
                   Text4.Text = ""
                   Command1.Enabled = True
                   Exit Sub
                End If
             End If
             Open CommonDialog1.FileName For Binary Access Read As #1
                  afileSize = LOF(1)
                  ReDim filebyte(1 To afileSize)
                  Get #1, , filebyte
             Close #1
             
             ReDim m_strEncodedFiles(1)
             m_strEncodedFiles(0) = Base64_EncodeBin(filebyte)
             
             fileAttach.AddItem Right(CommonDialog1.FileName, Len(CommonDialog1.FileName) - InStrRev(CommonDialog1.FileName, "\"))
             
             fileAttach.Text = fileAttach.List(0)
             
             isMultiple = False
          End If
       End If
    Else
       fileAttach.Clear
    End IfMe.MousePointer = 0
    Command1.Enabled = True
    Command3.Enabled = TrueStatusBar1.SimpleText = "发送邮件(SMTP) : " & str_SMTPMailAddressEnd SubPrivate Sub fileAttach_Click()
    fileAttach.ToolTipText = fileAttach.Text
    End SubPrivate Sub fileAttach_KeyDown(KeyCode As Integer, Shift As Integer)
    Dim I As Long
    Dim curIdx As Long
    If KeyCode = 46 And fileAttach.ListCount > 0 Then
       If MsgBox("确定要删除附件 " & fileAttach.List(fileAttach.ListIndex) & " 吗?", vbQuestion + vbYesNo + vbDefaultButton2, "提示") = vbYes Then
          curIdx = fileAttach.ListIndex
          For I = curIdx To fileAttach.ListCount - 2
              m_strEncodedFiles(I) = m_strEncodedFiles(I + 1)
          Next
          fileAttach.RemoveItem curIdx
       
          If fileAttach.ListCount > 0 Then
             fileAttach.Text = fileAttach.List(0)
          End If
       End If
    End If
    End SubPrivate Sub Form_Load()
    mPriority.ComboItems.Add 1, "p1", "高", 1
    mPriority.ComboItems.Add 2, "p3", "普通", 2
    mPriority.ComboItems.Add 3, "p5", "低", 3
    mPriority.ComboItems.Item(2).Selected = True
    StatusBar1.SimpleText = "发送邮件(SMTP) : " & str_SMTPMailAddress
    isBreak = False
    isMultiple = False
    fileAttach.Clear
    End Sub
      

  3.   

    '=== part3Private Sub SendWinsock_DataArrival(ByVal bytesTotal As Long)
        
        Dim idx As Long, Rcpts As Long
        Dim strTempRcpt() As String
        
        If SendWinsock.State <> 7 Then Exit Sub
        
        Dim strServerResponse   As String
        Dim strResponseCode     As String
        Dim strDataToSend       As String
        Dim strPriority         As String
        Const RandString As String = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890_"
        Dim Globalstr As String
        
        Select Case CStr(Trim(Replace(mPriority.SelectedItem.Key, "p", "")))
               Case "1"
                    strPriority = "High"
               Case "3"
                    strPriority = "Normal"
               Case "5"
                    strPriority = "Low"
        End Select
        
        
        For jd = 1 To 24
            uniquey = Int(Rnd * Len(RandString)) + 1
            Globalstr = Globalstr + Mid(RandString, uniquey, 1)
        Next jd
        strime1 = "Subject:" + Chr(32) + Text2.Text + vbCrLf ' Subject of E-Mail
        strime = Text3.Text + vbCrLf ' E-mail message body
        strime2 = "X-Priority: " & Trim(Replace(mPriority.SelectedItem.Key, "p", "")) + vbCrLf + "X-MSMail-Priority: " + strPriority + vbCrLf + "X-Mailer: MailChecker Ver:" & App.Major & "." & App.Minor & "." & App.Revision & "  Author:Johnny Lill" ' What program sent the e-mail, customize this
        'MULTI-PART Edit
        strime = "------=_NextPart_" + Globalstr + vbCrLf + "Content-Type: multipart/alternative; " + vbCrLf + Chr(9) + "boundary=""----=_NextPart_" + Globalstr + """" + vbCrLf + vbCrLf + "------=_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
        
        If fileAttach.ListCount > 0 Then
           strime = strime + "------=_NextPart_" + Globalstr + "--" + vbCrLf + vbCrLf
           If isMultiple Then
              For idx = 0 To fileAttach.ListCount - 1
                  strime = strime + "------=_NextPart_" + Globalstr + vbCrLf
                  strime = strime + "Content-Type: application/octet-stream;" + vbCrLf
                  strime = strime + Chr(9) + "Name=" + Chr(34) + fileAttach.List(idx) + Chr(34) + vbCrLf
                  strime = strime + "Content-Transfer-Encoding: base64" + vbCrLf
                  strime = strime + "Content-Disposition: attachment;" + vbCrLf
                  strime = strime + Chr(9) + "FileName=" + Chr(34) + fileAttach.List(idx) + Chr(34) + vbCrLf + vbCrLf
                  strime = strime + m_strEncodedFiles(idx) + vbCrLf
              Next
                  strime = strime + "------=_NextPart_" + Globalstr + "--" + vbCrLf
              
           Else
              strime = strime + "------=_NextPart_" + Globalstr + vbCrLf
              strime = strime + "Content-Type: application/octet-stream;" + vbCrLf
              strime = strime + Chr(9) + "Name=" + Chr(34) + fileAttach.Text + Chr(34) + vbCrLf
              strime = strime + "Content-Transfer-Encoding: base64" + vbCrLf
              strime = strime + "Content-Disposition: attachment;" + vbCrLf
              strime = strime + Chr(9) + "FileName=" + Chr(34) + fileAttach.Text + vbCrLf + vbCrLf
              strime = strime + m_strEncodedFiles(0) + vbCrLf
              strime = strime + "------=_NextPart_" + Globalstr + "--" + vbCrLf
           End If
        End If
        
        strimeall = strime1 + "MIME-Version: 1.0" + vbCrLf + strime2 + vbCrLf + "Content-Type: multipart/mixed; " + 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
        
      

  4.   

    '==== part4   If SendWinsock.State = 7 Then
           SendWinsock.GetData strServerResponse, vbString
        Else
           Exit Sub
        End If
        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
                     strDataToSend = Trim$(str_SMTPMailAddress)
                     strDataToSend = Left$(strDataToSend, _
                                     InStr(1, strDataToSend, "@") - 1)
                     If Trim(str_SMTPNeedLogin) = "0" Then
                        m_State = MAIL_LOGIN
                        SendWinsock.SendData "HELO " & strDataToSend & vbCrLf
                        StatusBar1.SimpleText = "登陆服务器"
                     ElseIf Trim(str_SMTPNeedLogin) = "1" Then
                        m_State = MAIL_HELO
                        SendWinsock.SendData "EHLO " & strDataToSend & vbCrLf
                        StatusBar1.SimpleText = "登陆服务器"
                     Else
                        MsgBox "SMTP设置有误,请重新设置后再试!", vbExclamation, "错误"
                        SendWinsock.Close
                        Unload Me
                     End If
                        
                Case MAIL_HELO
                     m_State = MAIL_USER
                     SendWinsock.SendData "AUTH LOGIN" & vbCrLf
                     StatusBar1.SimpleText = "正在校验用户名"
                Case MAIL_USER
                     m_State = MAIL_PASS
                     SendWinsock.SendData (Base64_Encode(Trim(str_SMTPLoginID))) & vbCrLf
                     StatusBar1.SimpleText = "校验用户密码"
                Case MAIL_PASS
                     m_State = MAIL_LOGIN
                     SendWinsock.SendData (Base64_Encode(Trim(str_SMTPPassword))) & vbCrLf
                     StatusBar1.SimpleText = "确认发送人邮件地址"
                Case MAIL_LOGIN
                     m_State = MAIL_FROM
                     SendWinsock.SendData "MAIL FROM:" & Trim$(str_SMTPMailAddress) & vbCrLf
                     StatusBar1.SimpleText = "确认接收人邮件地址"
                Case MAIL_FROM
                     m_State = MAIL_RCPTTO
                     If InStr(Text1.Text, ";") = 0 Then
                        SendWinsock.SendData "RCPT TO:" & Trim$(Text1.Text) & vbCrLf
                        strMailTO = "<" & Trim$(Text1.Text) & ">"
                     Else
                        strTempRcpt = Split(Trim$(Text1.Text), ";", -1, vbTextCompare)
                        For Rcpts = 0 To UBound(strTempRcpt)
                            SendWinsock.SendData "RCPT TO:" & Trim$(strTempRcpt(Rcpts)) & vbCrLf
                            If Rcpts = 0 Then
                               strMailTO = "<" & strTempRcpt(Rcpts) & ">," & vbCrLf
                            Else
                               If Rcpts = UBound(strTempRcpt) Then
                                  strMailTO = strMailTO & Chr(9) & "<" & strTempRcpt(Rcpts) & ">"
                               Else
                                  strMailTO = strMailTO & Chr(9) & "<" & strTempRcpt(Rcpts) & ">," & vbCrLf
                               End If
                            End If
                        Next
                     End If
                     StatusBar1.SimpleText = "邮件发送之中..."
                Case MAIL_RCPTTO
                     m_State = MAIL_DATA
                     SendWinsock.SendData "DATA" & vbCrLf
                     StatusBar1.SimpleText = "获取邮件内容"
                Case MAIL_DATA
                    m_State = MAIL_DOT
                    SendWinsock.SendData "From:" & str_SMTPMailAddress & " <" & str_SMTPMailAddress & ">" & vbCrLf
                    SendWinsock.SendData "To:" & strMailTO & vbCrLf
                    SendWinsock.SendData strimeall & vbCrLf
                    SendWinsock.SendData strime & vbCrLf
                    SendWinsock.SendData "." & vbCrLf
                    StatusBar1.SimpleText = "邮件送完毕"
                Case MAIL_DOT
                    m_State = MAIL_QUIT
                    SendWinsock.SendData "QUIT" & vbCrLf
                    StatusBar1.SimpleText = "邮件成功发送!!!"
                    MsgBox "邮件成功发送到: " & vbCrLf & Replace(Replace(strMailTO, Chr(9), ""), ",", ""), vbInformation, "提示"
                    SendWinsock.Close
                    Unload Me
                    
                Case MAIL_QUIT
             End Select
        Else
             SendWinsock.Close
        End If
    End SubPrivate Sub Text1_Change()
    Dim strTmp As String
    strTmp = Trim(Text1.Text)
    If strTmp = "" Then Command1.Enabled = False: Exit Sub
    If Trim(strTmp) <> "" And InStr(strTmp, "@") > 1 And InStr(strTmp, ".") > 2 And Right(strTmp, 1) <> "." < Len(strTmp) And Right(strTmp, 1) <> "@" And Abs(InStr(strTmp, "@") - InStr(strTmp, ".")) <> 1 And InStr(Right(strTmp, Len(strTmp) - InStr(strTmp, "@")), ".") <> 0 Then
       Command1.Enabled = True
    Else
       Command1.Enabled = False
    End If
    End SubPrivate Sub Text1_GotFocus()
    If Trim(Text1.Text) = "" Then
       Command1.Enabled = False
    End If
    End Sub
      

  5.   

    谢谢你  朋友
      我的E-Mail 为  ;   [email protected]
       再次感谢
      

  6.   

    我这有个现成的例子,可以和我联系[email protected]