'Option Compare Database
Option Explicit
' \\\|///
' \\ - - //
' ( @ @ )
'━━━━━━━━━━━━oOOo-(_)-oOOo━━━━━━━━━━━━━━
'-类名称: SendMail
'-功能描述: 发送邮件
'-参考:
'-使用注意:
'-兼容性: 2000,XP,2003
'-作者:
fan0217@tom.com'-更新日期： 2007-08-22
' Oooo
'━━━━━━━━━━oooO━-( )━━━━━━━━━━━━━━━━━
' ( ) ) /
' \ ( (_/
' \_)
Private Const cdoSendUsingMethod = "http://schemas.microsoft.com/cdo/configuration/sendusing"
Private Const cdoSendUsingPort = 2
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 cdoBasic = 1
Private Const cdoSendUserName = "http://schemas.microsoft.com/cdo/configuration/sendusername"
Private Const cdoSendPassword = "http://schemas.microsoft.com/cdo/configuration/sendpassword"
Private objConfig ' As CDO.Configuration
Private objMessage ' As CDO.Message
Private Fields ' As ADODB.Fields
Private strSMTPServer As String
Private strSendUserName As String
Private strSendPassword As String
Private strFromMail As String
Private intSMTPConnectionTimeout As Integer
Private intSMTPServerPort As Integer
Public Function Send(toMail As String, subject As String, textBody As String, Optional attachment As String = "") As Boolean
SendInitialize
With objMessage
.to = toMail '接收者的邮件地址
.From = FromMail '发送人的邮件地址
.subject = subject '标题
.textBody = textBody '正文
If attachment <> "" Then
.addAttachment attachment '邮件附件
End If
.Send
End With
Send = True
End Function
Private Sub SendInitialize()
Set objConfig = CreateObject("CDO.Configuration")
Set Fields = objConfig.Fields
With Fields
.Item(cdoSendUsingMethod) = cdoSendUsingPort
.Item(cdoSMTPServer) = SMTPServer
.Item(cdoSMTPServerPort) = SMTPServerPort
.Item(cdoSMTPConnectionTimeout) = SMTPConnectionTimeout
.Item(cdoSMTPAuthenticate) = cdoBasic
.Item(cdoSendUserName) = SendUserName
.Item(cdoSendPassword) = SendPassword
.Update
End With
Set objMessage = CreateObject("CDO.Message")
Set objMessage.Configuration = objConfig
End Sub
'可用的外部邮件服务器域名
Public Property Get SMTPServer() As String
SMTPServer = strSMTPServer
End Property
Public Property Let SMTPServer(ByVal value As String)
strSMTPServer = value
End Property
'邮件服务器的用户名
Public Property Get SendUserName() As String
SendUserName = strSendUserName
End Property
Public Property Let SendUserName(ByVal value As String)
strSendUserName = value
End Property
'邮件服务器的密码
Public Property Get SendPassword() As String
SendPassword = strSendPassword
End Property
Public Property Let SendPassword(ByVal value As String)
strSendPassword = value
End Property
'发件人的地址（要和SMTP相同）
Public Property Get FromMail() As String
FromMail = strFromMail
End Property
Public Property Let FromMail(ByVal value As String)
strFromMail = value
End Property
Public Property Get SMTPConnectionTimeout() As Integer
SMTPConnectionTimeout = intSMTPConnectionTimeout
End Property
Public Property Let SMTPConnectionTimeout(ByVal value As Integer)
intSMTPConnectionTimeout = value
End Property
Public Property Get SMTPServerPort() As Integer
SMTPServerPort = intSMTPServerPort
End Property
Public Property Let SMTPServerPort(ByVal value As Integer)
intSMTPServerPort = value
End Property
Private Sub Class_Initialize()
SMTPServerPort = 25
SMTPConnectionTimeout = 10
End Sub
Private Sub Class_Terminate()
Set Fields = Nothing
Set objMessage = Nothing
Set objConfig = Nothing
End Sub
发信测试
Sub Test()
Dim s As New SendMail '如果这里出错,就是你没有将类名称修改成:SendMail
s.SMTPServer = "SMTP.163.com"
s.SendUserName = "邮箱帐号"
s.SendPassword = "密码"
s.FromMail = "发信邮箱(
jjj@163.com)"
s.Send "收信箱(
uuu@qq.com)", "测试邮件", "收到请回复！--" & Now
Set s = Nothing
End Sub
Private Sub Command1_Click()
Test
End Sub
