'*****************************************************************************************'功能: 实现简单发送邮件的一个类'设计: OK_008'时间: 2007-07'*****************************************************************************************Option ExplicitPrivate cdoMessage As CDO.MessagePrivate 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 = 60Private 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 StringPrivate E_EmailFrom As StringPrivate E_EmailSubject As StringPrivate E_EmailTextBody As StringPublic Property Get SendUsingPort() As Byte SendUsingPort = E_SendUsingMethodEnd PropertyPublic Property Let SendUsingPort(SUPort As Byte) E_SendUsingMethod = SUPortEnd PropertyPublic Property Get SMTPAuthenticate() As Byte SMTPAuthenticate = E_SendSMTPAuthenticateEnd PropertyPublic Property Let SMTPAuthenticate(SMTPType As Byte) E_SendSMTPAuthenticate = SMTPTypeEnd PropertyPublic Property Get SMTPServer() As String SMTPServer = E_SMTPServerEnd PropertyPublic Property Let SMTPServer(sServerName As String) E_SMTPServer = sServerNameEnd PropertyPublic Property Get SMTPServerPort() As Integer SMTPServerPort = E_SMTPServerPortEnd PropertyPublic Property Let SMTPServerPort(ServerPort As Integer) E_SMTPServerPort = ServerPortEnd PropertyPublic Property Get SendUserName() As String SendUserName = E_SendUserNameEnd PropertyPublic Property Let SendUserName(ServerLoginUser As String) E_SendUserName = ServerLoginUserEnd PropertyPublic Property Get SendPassword() As String SendPassword = E_SendPasswordEnd PropertyPublic Property Let SendPassword(Pwd As String) E_SendPassword = PwdEnd PropertyPublic Property Get EmailTo() As String EmailTo = E_EmailToEnd PropertyPublic Property Let EmailTo(strEmail As String) E_EmailTo = strEmailEnd PropertyPublic Property Get EmailFrom() As String EmailFrom = E_EmailFromEnd PropertyPublic Property Let EmailFrom(strEmail As String) E_EmailFrom = strEmailEnd PropertyPublic Property Get EmailSubject() As String EmailSubject = E_EmailSubjectEnd PropertyPublic Property Let EmailSubject(strSubject As String) E_EmailSubject = strSubjectEnd PropertyPublic Property Get EmailTextBody() As String EmailTextBody = E_EmailTextBodyEnd PropertyPublic Property Let EmailTextBody(strTextBody As String) E_EmailTextBody = strTextBodyEnd Property'Error subPrivate Sub ErrorSub() MsgBox "Error " & Err.Number & " " & Err.Description, vbInformation + vbOKOnly, "Error Information"End Sub'Send EmailPublic 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 FunctionErr_SendEmail: ErrorSubEnd Function'Verify DataPrivate 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 FunctionErrorInput: MsgBox GetLanguageStr(StrMsg), vbInformation + vbOKOnly, GetLanguageStr("信息提示|")End Function'Save messages of configuration to databasePublic 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 FunctionErr_SaveConfigInfo: ErrorSubEnd Function'Read messages of configuration from databasePublic 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 SubErr_ReadConfigInfo: ErrorSubEnd SubPrivate Sub Class_Initialize() E_SendUsingMethod = 2 E_SendSMTPAuthenticate = 1 E_SMTPServerPort = 25 Set cdoMessage = New CDO.MessageEnd Sub