在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