sendmail.ctl

使用asp+sql编写的的各种程序案例

VERSION 5.00
Object = "{248DD890-BB45-11CF-9ABC-0080C7E7B78D}#1.0#0"; "MSWINSCK.OCX"
Begin VB.UserControl SendMail 
   ClientHeight    =   3540
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   4620
   ScaleHeight     =   3540
   ScaleWidth      =   4620
   Begin MSWinsockLib.Winsock Wsock 
      Left            =   240
      Top             =   360
      _ExtentX        =   741
      _ExtentY        =   741
      _Version        =   393216
   End
End
Attribute VB_Name = "SendMail"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit
'下面声明公有变量和模块级变量
'发送人姓名
Public strSendName As String
'接收人姓名
Public strReceiveName As String
'发送人信箱地址
Public strFromMail As String
'接收人信箱地址
Public strToMail As String
'email主题
Public strSubject As String
'email内容
Public strContent As String
'存储日期的变量
Dim m_Date As String
'接收服务器返回信息的字符串变量
Dim Information As String

Private Sub UserControl_Initialize()
'winsock控件采用TCP协议通讯
Wsock.Protocol = sckTCPProtocol
'将发送email的服务器指定为263的邮件发送服务器
Wsock.RemoteHost = "smtp.263.net"
'指定与发送邮件服务器连接的端口
Wsock.RemotePort = 25
End Sub

Private Sub Wsock_DataArrival(ByVal bytesTotal As Long)
'取得服务器返回的信息
Wsock.GetData Information
End Sub

Private Function WaitForResponse(strResponse As String, WaitTime As Integer) As Boolean
'该函数用于等待发送邮件服务器的相应码
Dim WaitSt As Date
'取得开始等待的时间
WaitSt = Now()
'如果服务器的返回消息（存储在information变量中）没有指定响应码则一直循环
'直到规定的时间
While InStr(1, Information, strResponse, vbTextCompare) < 1
    DoEvents
    If DateDiff("s", WaitSt, Now) > WaitTime Then
       Information = ""
       '在一定的时间内没有接到指定的响应码，函数返回值设为false
       WaitForResponse = False
       Exit Function
    End If
Wend
Information = ""
'接到服务器返回的响应码，函数返回值设置为true
WaitForResponse = True
End Function

Public Function SendMail() As String
'指定日期变量的内容
m_Date = Format(Date, "Ddd") & ", " & Format(Date, "dd Mmm YYYY") & " " & Format(Time, "hh:mm:ss") & "" & " -0600"
Dim mData As String

'发送的邮件消息主体
mData = "From:" & Chr(32) & strSendName & vbCrLf & _
        "Date:" & Chr(32) & m_Date & vbCrLf & _
        "X-Mailer: EBT Reporter v 2.x" & vbCrLf & _
        "To:" & Chr(32) & strReceiveName & vbCrLf & _
        "Subject:" & Chr(32) & strSubject & vbCrLf
'如果winsock处于打开状态，则先关闭连接
If Wsock.State <> sckClosed Then
    Wsock.Close
End If

'连接SMTP服务器
Wsock.Connect

'等待服务器的响应码
If Not WaitForResponse("220", 10) Then
    SendMail = "邮件服务器连接不上......"
    Exit Function
End If

'发送打开对话的请求
Wsock.SendData "HELO" & " " & Wsock.LocalHostName & vbCrLf
If Not WaitForResponse("250", 10) Then
    SendMail = "无法打开邮件发送对话" & vbCrLf
    Exit Function
End If

'发送发送方地址
Wsock.SendData "MAIL FROM:" & " " & strFromMail & vbCrLf
If Not WaitForResponse("250", 10) Then
    SendMail = "无法发送发送方地址" & vbCrLf
    Exit Function
End If

'发送接收方地址
Wsock.SendData "RCPT TO:" & " " & strToMail & vbCrLf
If Not WaitForResponse("250", 10) Then
    SendMail = "无法发送接收方地址" & vbCrLf
    Exit Function
End If

'发送消息体
Wsock.SendData "DATA" & vbCrLf
If Not WaitForResponse("354", 10) Then
    SendMail = "无法发送消息体" & vbCrLf
    Exit Function
End If
Wsock.SendData mData & vbCrLf
Wsock.SendData strContent & vbCrLf
Wsock.SendData "." & vbCrLf
If Not WaitForResponse("250", 20) Then
    SendMail = "消息体发送不成功" & vbCrLf
    Exit Function
End If

'结束邮件发送对话
Wsock.SendData "QUIT" & vbCrLf
If Not WaitForResponse("221", 10) Then
    Exit Function
End If
Wsock.Close
SendMail = "邮件发送成功"
End Function

Public Property Let SmtpServer(ByVal vNewValue As String)
'指定发送邮件的smtp服务器
Wsock.RemoteHost = vNewValue
End Property