' ***************************************************************************************** ' 功能: 实现简单发送邮件的一个类 ' 设计: OK_008 ' 时间: 2007-07 ' ***************************************************************************************** Option Explicit Private cdoMessage As CDO.Message Private Const cdoSendUsingMethod = " http://schemas.microsoft.com/cdo/configuration/sendusing " Private Const cdoSMTPServer = " http://schemas.microsoft.com/cdo/configuration/smtpserver " Private Const cdoSMTPServerPort = " http://schemas.microsoft.com/cdo/configuration/smtpserverport " Private Const cdoSMTPConnectionTimeout = " http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout " Private Const cdoSMTPAuthenticate = " http://schemas.microsoft.com/cdo/configuration/smtpauthenticate " Private Const cdoSendUserName = " http://schemas.microsoft.com/cdo/configuration/sendusername " Private Const cdoSendPassword = " http://schemas.microsoft.com/cdo/configuration/sendpassword " Private Const SMTPConnectionTimeout = 60 Private E_SendUsingMethod As Byte ' 邮件发送选项 Private E_SendSMTPAuthenticate As Byte ' SMTP验证选项 Private E_SMTPServer As String ' SMTP服务器 Private E_SMTPServerPort As Integer ' SMTP服务器端口 Private E_SendUserName As String ' 用户名 Private E_SendPassword As String ' 密码 Private E_EmailTo As String Private E_EmailFrom As String Private E_EmailSubject As String Private E_EmailTextBody As String Public Property Get SendUsingPort() As Byte SendUsingPort = E_SendUsingMethod End Property Public Property Let SendUsingPort(SUPort As Byte ) E_SendUsingMethod = SUPort End Property Public Property Get SMTPAuthenticate() As Byte SMTPAuthenticate = E_SendSMTPAuthenticate End Property Public Property Let SMTPAuthenticate(SMTPType As Byte ) E_SendSMTPAuthenticate = SMTPType End Property Public Property Get SMTPServer() As String SMTPServer = E_SMTPServer End Property Public Property Let SMTPServer(sServerName As String ) E_SMTPServer = sServerName End Property Public Property Get SMTPServerPort() As Integer SMTPServerPort = E_SMTPServerPort End Property Public Property Let SMTPServerPort(ServerPort As Integer ) E_SMTPServerPort = ServerPort End Property Public Property Get SendUserName() As String SendUserName = E_SendUserName End Property Public Property Let SendUserName(ServerLoginUser As String ) E_SendUserName = ServerLoginUser End Property Public Property Get SendPassword() As String SendPassword = E_SendPassword End Property Public Property Let SendPassword(Pwd As String ) E_SendPassword = Pwd End Property Public Property Get EmailTo() As String EmailTo = E_EmailTo End Property Public Property Let EmailTo(strEmail As String ) E_EmailTo = strEmail End Property Public Property Get EmailFrom() As String EmailFrom = E_EmailFrom End Property Public Property Let EmailFrom(strEmail As String ) E_EmailFrom = strEmail End Property Public Property Get EmailSubject() As String EmailSubject = E_EmailSubject End Property Public Property Let EmailSubject(strSubject As String ) E_EmailSubject = strSubject End Property Public Property Get EmailTextBody() As String EmailTextBody = E_EmailTextBody End Property Public Property Let EmailTextBody(strTextBody As String ) E_EmailTextBody = strTextBody End Property ' Error sub Private Sub ErrorSub() MsgBox " Error " & Err.Number & " " & Err.Description, vbInformation + vbOKOnly, " Error Information " End Sub ' Send Email Public Function SendEmail() As Boolean On Error GoTo Err_SendEmail ' Configuration With cdoMessage.Configuration.Fields .Item(cdoSendUsingMethod) = E_SendUsingMethod .Item(cdoSMTPServer) = E_SMTPServer .Item(cdoSMTPServerPort) = E_SMTPServerPort .Item(cdoSMTPConnectionTimeout) = SMTPConnectionTimeout .Item(cdoSMTPAuthenticate) = E_SendSMTPAuthenticate .Item(cdoSendUserName) = E_SendUserName .Item(cdoSendPassword) = E_SendPassword .Update End With ' Message With cdoMessage .To = E_EmailTo .From = E_EmailFrom .Subject = E_EmailSubject .TextBody = E_EmailTextBody .Send End With SendEmail = True Exit Function Err_SendEmail: ErrorSub End Function ' Verify Data Private Function VerifyData() As Boolean Dim StrMsg As String If E_SMTPServer = "" Then StrMsg = " SMTP服务器名没有填写| " GoTo ErrorInput End If If E_SMTPServerPort <= 0 Then StrMsg = " SMTP 端口没有填写| " GoTo ErrorInput End If If E_SendUserName = "" Then StrMsg = " 用户名没有填写| " GoTo ErrorInput End If If E_SendPassword = "" Then StrMsg = " 密码没有填写| " GoTo ErrorInput End If VerifyData = True Exit Function ErrorInput: MsgBox GetLanguageStr(StrMsg), vbInformation + vbOKOnly, GetLanguageStr( " 信息提示| " ) End Function ' Save messages of configuration to database Public Function SaveConfigInfo(Optional ByVal intUpdateTyp As Integer = 1 ) As Boolean Dim objDBB As Object Dim strSQL As String On Error GoTo Err_SaveConfigInfo If Not VerifyData Then Exit Function ' 代码略 SaveConfigInfo = True Exit Function Err_SaveConfigInfo: ErrorSub End Function ' Read messages of configuration from database Public Sub ReadConfigInfo() Dim objDBB As Object Dim objRst As ADODB.Recordset On Error GoTo Err_ReadConfigInfo ' 其中的代码略 If Not objRst.EOF Then E_SendUsingMethod = objRst!SendUsingMethod E_SMTPServer = objRst!SMTPServer E_SMTPServerPort = objRst!ServerPort E_SendSMTPAuthenticate = objRst!Authenticate E_SendUserName = objRst!SendUserName E_SendPassword = objRst!SendPassword E_EmailTo = objRst!EmailTo End If If objRst.State = adStateOpen Then objRst.Close Set objRst = Nothing Set objDBB = Nothing Exit Sub Err_ReadConfigInfo: ErrorSub End Sub Private Sub Class_Initialize() E_SendUsingMethod = 2 E_SendSMTPAuthenticate = 1 E_SMTPServerPort = 25 Set cdoMessage = New CDO.Message End Sub