在VB6中写的一个发送简单邮件的类

 

' *****************************************************************************************
' 功能: 实现简单发送邮件的一个类
' 设计: 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