设为首页收藏本站Access中国

Office中国论坛/Access中国论坛

 找回密码
 注册

QQ登录

只需一步,快速开始

12下一页
返回列表 发新帖
查看: 10336|回复: 13

[模块/函数] 使用CDO发送邮件(类模块)

[复制链接]
发表于 2008-3-1 14:37:37 | 显示全部楼层 |阅读模式
  1. Option Compare Database
  2. Option Explicit
  3. '                           \\\|///
  4. '                         \\  - -  //
  5. '                          (  @ @  )
  6. '━━━━━━━━━━━━oOOo-(_)-oOOo━━━━━━━━━━━━━━
  7. '-类名称:       SendMail
  8. '-功能描述:     发送邮件
  9. '-参考:
  10. '-使用注意:
  11. '-兼容性:       2000,XP,2003
  12. '-作者:         fan0217@tom.com
  13. '-更新日期:    2007-08-22
  14. '                            Oooo
  15. '━━━━━━━━━━oooO━-(   )━━━━━━━━━━━━━━━━━
  16. '                    (   )   ) /
  17. '                     \ (   (_/
  18. '                      \_)
  19. Private Const cdoSendUsingMethod = "http://schemas.microsoft.com/cdo/configuration/sendusing"
  20. Private Const cdoSendUsingPort = 2
  21. Private Const cdoSMTPServer = "http://schemas.microsoft.com/cdo/configuration/smtpserver"
  22. Private Const cdoSMTPServerPort = "http://schemas.microsoft.com/cdo/configuration/smtpserverport"
  23. Private Const cdoSMTPConnectionTimeout = "http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout"
  24. Private Const cdoSMTPAuthenticate = "http://schemas.microsoft.com/cdo/configuration/smtpauthenticate"
  25. Private Const cdoBasic = 1
  26. Private Const cdoSendUserName = "http://schemas.microsoft.com/cdo/configuration/sendusername"
  27. Private Const cdoSendPassword = "http://schemas.microsoft.com/cdo/configuration/sendpassword"
  28. Private objConfig ' As CDO.Configuration
  29. Private objMessage ' As CDO.Message
  30. Private Fields ' As ADODB.Fields
  31. Private strSMTPServer As String
  32. Private strSendUserName As String
  33. Private strSendPassword As String
  34. Private strFromMail As String
  35. Private intSMTPConnectionTimeout As Integer
  36. Private intSMTPServerPort As Integer

  37. Public Function Send(toMail As String, subject As String, textBody As String, Optional attachment As String = "") As Boolean
  38.     SendInitialize
  39.     With objMessage
  40.         .to = toMail '接收者的邮件地址
  41.         .From = FromMail '发送人的邮件地址
  42.         .subject = subject '标题
  43.         .textBody = textBody '正文
  44.         If attachment <> "" Then
  45.             .addAttachment attachment '邮件附件
  46.         End If
  47.         .Send
  48.     End With
  49.     Send = True
  50. End Function

  51. Private Sub SendInitialize()
  52.     Set objConfig = CreateObject("CDO.Configuration")
  53.     Set Fields = objConfig.Fields
  54.     With Fields
  55.         .Item(cdoSendUsingMethod) = cdoSendUsingPort
  56.         .Item(cdoSMTPServer) = SMTPServer
  57.         .Item(cdoSMTPServerPort) = SMTPServerPort
  58.         .Item(cdoSMTPConnectionTimeout) = SMTPConnectionTimeout
  59.         .Item(cdoSMTPAuthenticate) = cdoBasic
  60.         .Item(cdoSendUserName) = SendUserName
  61.         .Item(cdoSendPassword) = SendPassword
  62.         .Update
  63.     End With
  64.     Set objMessage = CreateObject("CDO.Message")
  65.     Set objMessage.Configuration = objConfig
  66. End Sub

  67. '可用的外部邮件服务器域名
  68. Public Property Get SMTPServer() As String
  69.     SMTPServer = strSMTPServer
  70. End Property
  71. Public Property Let SMTPServer(ByVal value As String)
  72.     strSMTPServer = value
  73. End Property

  74. '邮件服务器的用户名
  75. Public Property Get SendUserName() As String
  76.     SendUserName = strSendUserName
  77. End Property
  78. Public Property Let SendUserName(ByVal value As String)
  79.     strSendUserName = value
  80. End Property

  81. '邮件服务器的密码
  82. Public Property Get SendPassword() As String
  83.     SendPassword = strSendPassword
  84. End Property
  85. Public Property Let SendPassword(ByVal value As String)
  86.     strSendPassword = value
  87. End Property

  88. '发件人的地址(要和SMTP相同)
  89. Public Property Get FromMail() As String
  90.     FromMail = strFromMail
  91. End Property
  92. Public Property Let FromMail(ByVal value As String)
  93.     strFromMail = value
  94. End Property

  95. Public Property Get SMTPConnectionTimeout() As Integer
  96.     SMTPConnectionTimeout = intSMTPConnectionTimeout
  97. End Property
  98. Public Property Let SMTPConnectionTimeout(ByVal value As Integer)
  99.     intSMTPConnectionTimeout = value
  100. End Property

  101. Public Property Get SMTPServerPort() As Integer
  102.     SMTPServerPort = intSMTPServerPort
  103. End Property
  104. Public Property Let SMTPServerPort(ByVal value As Integer)
  105.     intSMTPServerPort = value
  106. End Property

  107. Private Sub Class_Initialize()
  108.     SMTPServerPort = 25
  109.     SMTPConnectionTimeout = 10
  110. End Sub

  111. Private Sub Class_Terminate()
  112.     Set Fields = Nothing
  113.     Set objMessage = Nothing
  114.     Set objConfig = Nothing
  115. End Sub
复制代码
 楼主| 发表于 2008-3-1 14:38:30 | 显示全部楼层
  1. Sub Test()
  2. Dim s As New SendMail
  3. s.SMTPServer = "SMTP.tom.com"
  4. s.SendUserName = "fan0217"
  5. s.SendPassword = "**********"
  6. s.FromMail = "fan0217@tom.com"
  7. s.Send "fan0217@tom.com", "测试邮件", "收到请回复!--" & Now
  8. Set s = Nothing
  9. End Sub
复制代码
发表于 2008-3-1 14:41:50 | 显示全部楼层
沙发
学习学习
发表于 2008-3-1 15:05:15 | 显示全部楼层
发表于 2008-3-1 15:48:17 | 显示全部楼层
.

点击这里给我发消息

发表于 2008-3-1 16:37:25 | 显示全部楼层
呵呵, 刚看到一个CDO例程, 又白白收了一个CDO的类库, 赶快收藏了!! 谢谢分享
发表于 2009-12-23 20:31:45 | 显示全部楼层
谢谢分享
发表于 2010-12-1 15:23:42 | 显示全部楼层
太经典了。
发表于 2015-3-26 23:19:45 | 显示全部楼层
发表于 2016-2-2 12:07:18 | 显示全部楼层
要仔细学习下,谢谢
您需要登录后才可以回帖 登录 | 注册

本版积分规则

QQ|站长邮箱|小黑屋|手机版|Office中国/Access中国 ( 粤ICP备10043721号-1 )  

GMT+8, 2024-3-29 08:34 , Processed in 0.094543 second(s), 34 queries .

Powered by Discuz! X3.3

© 2001-2017 Comsenz Inc.

快速回复 返回顶部 返回列表