VBA利用Notes自动发送邮件

1、新建Excel文件，打开后另存为Test.xlsm(启用宏的文档)格式，如图所示。

2、在键盘上按Alt+F11，弹出VBA代码编辑器，在当前Excel的文件目录下点击鼠标右键，弹出选择框，选择插入-->模块。如图所示。

3、添加如下函数。

Private Sub SendNotesMail(Subject As String, Attachment As String, Recipient As String, BodyText As String, SaveIt As Boolean, BCC As String)

'设置对象属性Set up the objects required for Automation into lotus notes

    Dim Maildb As Object 'The mail database

    Dim UserName As String 'The current users notes name

    Dim MailDbName As String 'THe current users notes mail database name

    Dim MailDoc As Object 'The mail document itself

    Dim AttachME As Object 'The attachment richtextfile object

    Dim Session As Object 'The notes session

    Dim EmbedObj As Object 'The embedded object (Attachment)

    '创建Notes会话

    Set Session = CreateObject("Notes.NotesSession")

    '就想帮助文件里面提到的那样，COM用户必须先初始化会话方可继续Domino对象的操控，仅适用于 5.x 以上版本.

    'Session.Initialize ("Ncut159")

    '取得用户名并计算邮件文件名

    '在某些情况，假如你传递一个空字符串到 MailDBname 变量，一样能够发送邮件，只要ID口令正确就可以了.

    UserName = Session.UserName

    'MailDbName = Left$(UserName, 1) & Right$(UserName, (Len(UserName) - InStr(1, UserName, " "))) & ".nsf"

    MailDbName = Cells(1, 8).Text

    '打开Notes邮箱

    Set Maildb = Session.GetDatabase("", MailDbName)

     If Maildb.IsOpen = True Then

          '判断已经打开

     Else

         Maildb.OPENMAIL

     End If

    '创建新邮件

    Set MailDoc = Maildb.CreateDocument

    MailDoc.Form = "Memo"

    MailDoc.sendto = Recipient

    '如果想把邮件发给几个人，用抄送或者密送就可以了：

    MailDoc.BlindCopyTo = BCC

    MailDoc.Subject = Subject

    MailDoc.Body = BodyText

    MailDoc.SaveMessageOnSend = SaveIt

    '设置嵌入对象，添加附件

    If Attachment <> "" Then

        Set AttachME = MailDoc.CreateRichTextItem("Attachment")

        Set EmbedObj = AttachME.EmbedObject(1454, "", Attachment, "Attachment")

    'Attachment格式为：c:/my documents/report.doc

    '下一行要注释掉，不然会出现"Rich text item Attachment already exists."的错误提示

        'MailDoc.CreateRichTextItem ("Attachment")

    End If

    '发送文档

    MailDoc.PostedDate = Now() '加上PostedDate，邮件就会出现在发件箱

    MailDoc.Send 0, Recipient

    '清理状态

    Set Maildb = Nothing

    Set MailDoc = Nothing

    Set AttachME = Nothing

    Set Session = Nothing

    Set EmbedObj = Nothing

End Sub

4、4使用for循环引用该方法

Sub 批量发邮件()  '每次发一人的资料

Dim rng As Range, MyMail As String

For Each rng In Range([b2], Cells(Rows.Count, 2).End(xlUp))   

   Call SendNotesMail("未收到hardcopy报销", "", rng.Offset(0, 1).Text, "Dear " & rng.Offset(0, -1) & "您金额为" & rng.Text & "元的报销" & "超过1个月仍未收到hardcopy，为了您的报销尽快处理，烦请跟进解决，谢谢您的支持与配合。", True, "")

Next

End Sub

5、5 基础数据准备

A列为名字，B列为对应数据，C列为邮箱。      H1为对应邮箱nsf的路径。一般在C:\notesdata\mail10\***.nsf