使用VBA操作Lotus Notes

winland

之前在这个帖子中讨论了使用VBA发送Lotus Notes邮件，那个帖子中还有些问题一直没有解决，例如签名。另外之前自己也认为不能使用Lotus Notes的UI操作，实际上是错的。
这里开一个新贴提供一些关于使用VBA操作Notes的例子，主要涉及Notes的邮件功能。使用的Notes版本是R6。如有不足的地方，希望大家补充。

1. 获取当前用户名
Sub GetUserName()
    Dim aNotes
   
    ' 创建NoteSession对象
    Set aNotes = CreateObject("Notes.NotesSession")
   
    ' 获取用户名
    MsgBox aNotes.UserName
   
    Set aNotes = Nothing
End Sub

2. 访问数据库
Sub AccessDataBase()
    Dim aNotes
    Dim aDataBase
    Dim strTemp As String
   
    Set aNotes = CreateObject("Notes.NotesSession")
   
    ' 获取当前数据库
    Set aDataBase = aNotes.CURRENTDATABASE
   
    ' 获取服务器上指定数据库
    'Set aDataBase = aNotes.GetDatabase("server/subfolder", "mail/yourname")
   
    ' 获取本地联系人数据库
    'Set aDataBase = aNotes.GetDatabase("", "names")
   
    ' 获取本地数据库
    'Set aDataBase = aNotes.GetDataBase("", "c:\work\temp.nsf")
   
    strTemp = "共有邮件：" & aDataBase.AllDocuments.Count
    strTemp = strTemp & vbCrLf & "数据库标题：" & aDataBase.Title
    strTemp = strTemp & vbCrLf & "数据库文件：" & aDataBase.Filename
    strTemp = strTemp & vbCrLf & "数据库" & IIf(aDataBase.IsOpen, "已打开", "未打开")
   
    MsgBox strTemp
    Set aNotes = Nothing
    Set aDataBase = Nothing
    Set aDocument = Nothing
End Sub

3. 判断数据库是否打开
Sub OpenDataBase()
    Dim aNotes
    Dim aDataBase
    Dim strTemp As String
   
    Set aNotes = CreateObject("Notes.NotesSession")
   
    Set aDataBase = aNotes.GetDataBase("", "")
    If aDataBase.IsOpen Then
        MsgBox "Is Open"
    Else
        MsgBox "Not Open"
    End If
    aDataBase.Open "", "c:\work\temp.nsf"
    If aDataBase.IsOpen Then
        MsgBox aDataBase.Title & "已打开", , aDataBase.Filename
    Else
        MsgBox "未打开", , aDataBase.Filename
    End If
   
    Set aNotes = Nothing
    Set aDataBase = Nothing
End Sub
这种打开方式只是用来提供后续操作，并不是表示在Notes窗口中打开该数据库。


4. 使用UIWorkspace对象打开指定数据库
Sub AccessUI()
    Dim aNotesUI
    Set aNotesUI = CreateObject("Notes.NotesUIWorkspace")
    Call aNotesUI.OpenDataBase("", "c:\work\temp.nsf")
   
    Set aNotesUI = Nothing
End Sub
使用UIWorkspace对象则可以在Notes窗口中打开指定数据库。


5. 根据模板创建本地邮件数据库
Sub CreateMailDatabase()
    Dim aNotes
    Dim aDataBase
    Dim dbTemp
    Dim strTemp As String
   
    Set aNotes = CreateObject("Notes.NotesSession")
    ' 指定模板文件
    Set dbTemp = aNotes.GetDataBase("", "mail6.ntf")
    ' 第一个参数指定服务器名称，如果为空表示生成本地数据库
    ' 第二个参数表示数据库文件名称
    ' 第三个参数表示是否继承未来的设计变化
    Set aDataBase = dbTemp.CREATEFROMTEMPLATE("", "TestDB", True)
   
    aDataBase.Title = "Just Test"
   
    Set aNotes = Nothing
    Set dbTemp = Nothing
    Set aDataBase = Nothing
End Sub
这样创建的数据库并没有添加到Notes的Workspace中，但在C:\Program Files\Lotus\Notes\Data目录下生成TestDB.nsf数据库文件。

6. 连接UIDocument和Document
Sub ConnectUIandDoc()
  Dim workspace As Object
  Dim uidoc As Object
  Dim doc As Object
  Dim db As Object
  Set workspace = CreateObject("Notes.NotesUIWorkspace")
  ' 设置uidoc为NotesUIDocument对象
  Set uidoc = workspace.CURRENTDOCUMENT
  ' 将NotesUIDocument对象赋给NotesDocument对象
  Set doc = uidoc.DOCUMENT
  Set db = doc.PARENTDATABASE
  MsgBox "Parent database: " & db.Title
  Set db = Nothing
  Set doc = Nothing
  Set uidoc = Nothing
  Set workspace = Nothing
End Sub

7. 列出当前数据库中所有的文档（默认打开邮件数据库，列出所有邮件）。
Sub ListAllDocument()
  Dim aNotes
  Dim aDataBase
  Dim aDC
  Dim aDoc
  Dim i As Integer
  
  Set aNotes = CreateObject("Notes.NotesSession")
  Set aDataBase = aNotes.CURRENTDATABASE
  Set aDC = aDataBase.AllDocuments
  Debug.Print aDC.Count                                                ' 所有文档总数
  Set aDoc = aDC.GETFIRSTDOCUMENT                                ' 获取第一个邮件
  i = 1
  While Not (aDoc Is Nothing)
     Cells(i, 1) = aDoc.GETFIRSTITEM("From").text                ' 发件人
     Cells(i, 2) = aDoc.GETFIRSTITEM("Subject").text                ' 标题
     i = i + 1
    Set aDoc = aDC.GetNextDocument(aDoc)                        ' 获取下一个邮件
  Wend
  Set aNotes = Nothing
  Set aDataBase = Nothing
  Set aDC = Nothing
  Set aDoc = Nothing
End Sub

8. 列出收件箱中所有的邮件
Sub ListInboxDocument()
  Dim aNotes
  Dim aDataBase
  Dim aView
  Dim aDoc
  Dim i As Integer
  
  Set aNotes = CreateObject("Notes.NotesSession")
  Set aDataBase = aNotes.CURRENTDATABASE
  Set aView = aDataBase.getview("($Inbox)")                        ' 获取收件箱
  Debug.Print aView.ALLENTRIES.Count                                ' 所有文档总数
  Set aDoc = aView.GETFIRSTDOCUMENT
  i = 1
  While Not (aDoc Is Nothing)
     Cells(i, 1) = aDoc.GETFIRSTITEM("From").text
     Cells(i, 2) = aDoc.GETFIRSTITEM("Subject").text
     i = i + 1
    Set aDoc = aView.GetNextDocument(aDoc)
  Wend
  Set aNotes = Nothing
  Set aDataBase = Nothing
  Set aView = Nothing
  Set aDoc = Nothing
End Sub
可以使用Set aView = aDataBase.getview("($Sent)")获得发件箱。

9. 列出当前数据库中所有的视图
Sub GetAllViews()
    Dim aNotes
    Dim aDataBase
    Dim aView
    Dim j As Integer
   
    Set aNotes = CreateObject("Notes.NotesSession")
    Set aDataBase = aNotes.CURRENTDATABASE
    j = 1
    For Each aView In aDataBase.views
        Cells(j, 1) = aView.Name
        Cells(j, 2) = aView.IsFolder
        j = j + 1
    Next
    Set aNotes = Nothing
    Set aDataBase = Nothing
    Set aView = Nothing
End Sub
如果是邮件数据库可以列出诸如收件箱、发件箱、草稿箱和垃圾箱等等视图的名称。

10. 列出指定文档的所有Item。
Sub ListDocItems()
    Dim aNotes
    Dim aDataBase
    Dim aDocument
    Dim aView
    Dim aItem
    Dim i
   
    Set aNotes = CreateObject("Notes.NotesSession")
    Set aDataBase = aNotes.CURRENTDATABASE
    Set aView = aDataBase.getview("($Inbox)")
    If (aView Is Nothing) Then
        MsgBox "Inbox view don't exist!"
    Else
        Set aDocument = aView.GETFIRSTDOCUMENT
        i = 1
        For Each aItem In aDocument.Items
            Cells(i, 1) = aItem.Type
            Cells(i, 2) = aItem.Name
            Cells(i, 3) = aItem.text
            i = i + 1
        Next
    End If
    Set aNotes = Nothing
    Set aDataBase = Nothing
    Set aView = Nothing
    Set aDocument = Nothing
    Set aItem = Nothing
End Sub
这些Item构成一个文档或者说一个邮件，这些Item的内容也可以使用类似aDoc.GETFIRSTITEM("From").Text的方法来获取。

11. 列出邮件正文中的所有嵌入对象，包括Excel工作表、附件等。（正文中嵌入的图片不知道怎么获得）
Sub ListItemofBody()
    Dim aNotes
    Dim aDataBase
    Dim aDocument
    Dim aView
    Dim aItem
    Dim oEmb
   
    Set aNotes = CreateObject("Notes.NotesSession")
    Set aDataBase = aNotes.CURRENTDATABASE
    Set aView = aDataBase.getview("($Inbox)")
    If (aView Is Nothing) Then
        MsgBox "Inbox view don't exist!"
    Else
        ' 本例中只列出第一个邮件的嵌入对象
        Set aDocument = aView.GETFIRSTDOCUMENT
        Set rtItem = aDocument.GETFIRSTITEM("Body")
        Debug.Print rtItem.text
        If (rtItem.Type = 1) Then
            For Each oEmb In rtItem.EmbeddedObjects
                Debug.Print oEmb.Type & " " & oEmb.Name
            Next
        End If
    End If
    Set aNotes = Nothing
    Set aDataBase = Nothing
    Set aView = Nothing
    Set aDocument = Nothing
    Set aItem = Nothing
End Sub
其中嵌入对象的类型包括：
EMBED_ATTACHMENT (1454)
EMBED_OBJECT (1453)
EMBED_OBJECTLINK (1452)

12. 搜索指定条件邮件
Sub SearchDocument()
  Dim aNotes
  Dim aDatabase
  Dim aDC
  Dim aDoc
  Dim i As Integer
  Dim dt
  
  Set aNotes = CreateObject("Notes.NotesSession")
  Set aDatabase = aNotes.CURRENTDATABASE
  ' 指定日期
  Set dt = aNotes.CREATEDATETIME("03/03/10")
  
  Set aDC = aDatabase.Search("@Contains(Subject;""FW"")", dt, 0)
  'Set aDC = aDatabase.Search("@Contains(Subject;""FW"")", Nothing, 0)
  Set aDoc = aDC.GETFIRSTDOCUMENT()
  i = 1
  While Not (aDoc Is Nothing)
    Cells(i, 1) = aDoc.GETFIRSTITEM("From").text
    Cells(i, 2) = aDoc.GETFIRSTITEM("Subject").text
    i = i + 1
    Set aDoc = aDC.GetNextDocument(aDoc)
  Wend
  Set aNotes = Nothing
  Set aDatabase = Nothing
  Set aDC = Nothing
  Set aDoc = Nothing
  Set dt = Nothing
End Sub
aDatabase.Search("@Contains(Subject;""FW"")", dt, 0)表示搜索数据库中从dt所表示的日期开始的主题包含“FW"字符串的邮件。
语法：
Set notesDocumentCollection = notesDatabase.Search( formula$, notesDateTime, maxDocs% )
参数formula$：使用@function公式定义搜索条件；
参数notesDateTime：开始时间，如果设置Nothing则表示没有开始时间。
参数mxDocs%：返回的最大邮件数。设为0时表示匹配所有邮件。


13. 下载附件
Sub GetAttachement()
    Dim aNotes
    Dim aDataBase
    Dim aDocument
    Dim aView
    Dim rtItem
    Dim oEmb
   
    Set aNotes = CreateObject("Notes.NotesSession")
    Set aDataBase = aNotes.CURRENTDATABASE
    Set aView = aDataBase.getview("($Inbox)")
    If (aView Is Nothing) Then
        MsgBox "Inbox view don't exist!"
    Else
        ' 本例只是处理第一个邮件
        Set aDocument = aView.GETFIRSTDOCUMENT
        Debug.Print aDocument.GETFIRSTITEM("From").text                     ' 发送者
        Debug.Print aDocument.GETFIRSTITEM("Subject").text                  ' 主题
        Debug.Print aDocument.GETFIRSTITEM("posteddate").text               ' 发送时间
        Set rtItem = aDocument.GETFIRSTITEM("Body")
        If (rtItem.Type = 1) Then
            For Each oEmb In rtItem.EmbeddedObjects
                If (oEmb.Type = 1454) Then                                ' 附件类型
                    Call oEmb.ExtractFile("c:\" & oEmb.Source)
                End If
            Next
        End If
    End If
    Set aNotes = Nothing
    Set aDataBase = Nothing
    Set aView = Nothing
    Set aDocument = Nothing
End Sub

14. 设置签名档
Sub SetSignature()
    Dim aNotes
    Dim aDataBase
    Dim aProf
   
    Set aNotes = CreateObject("Notes.NotesSession")
    Set aDataBase = aNotes.CURRENTDATABASE
    Set aProf = aDataBase.GetProfileDocument("CalendarProfile")
    Call aProf.ReplaceItemValue("EnableSignature", "1")
    'Call aProf.ReplaceItemValue("SignatureOption", "1")
    'Call aProf.ReplaceItemValue("Signature_1", "In god we trust")
    Call aProf.ReplaceItemValue("SignatureOption", "2")
    Call aProf.ReplaceItemValue("Signature_2", "C:\test.jpg")
    Call aProf.ComputeWithForm(True, False)
    Call aProf.Save(True, False)
    Set aNotes = Nothing
    Set aDataBase = Nothing
    Set aProf = Nothing
End Sub
语句aProf.ReplaceItemValue("EnableSignature", "1")表示勾选“Automatically append a signature to the bottom of my outgoing mail messages"。"0"表示不勾选。
语句Call aProf.ReplaceItemValue("SignatureOption", "1")表示勾选“Text”。
语句Call aProf.ReplaceItemValue("Signature_1", "In god we trust")表示设置文本签名档内容。
语句Call aProf.ReplaceItemValue("SignatureOption", "2")表示勾选“HTML or Image File”。
语句Call aProf.ReplaceItemValue("Signature_2", "C:\test.jpg")设置HTML或Image文件路径名，也可以使用文本文件。


15. 发送邮件时添加签名档
Sub SendEmailwithSignature()
    Dim aNotes
    Dim aDatabase
    Dim aDocument
    Dim strSign As String
   
    Set aNotes = CreateObject("Notes.NotesSession")
    Set aDatabase = aNotes.CURRENTDATABASE
    strSign = aDatabase.GetProfileDocument("CalendarProfile") _
                                            .GETITEMVALUE("Signature")(0)
                                            
    Set aDocument = aDatabase.CREATEDOCUMENT
    aDocument.Subject = "test"
    aDocument.SendTo = "test@xxx.com"
    aDocument.Form = "Memo"
    aDocument.Body = "This is a test to using Signature." & VbCrLf & VbCrLf & strSign
    aDocument.SAVEMESSAGEONSEND = True
    aDocument.PostedDate = Now
    ' 发送邮件
    'Call aDocument.SEND(False)
    ' 保存邮件
    Call aDocument.Save(True, False)
   
    Set aNotes = Nothing
    Set aDatabase = Nothing
    Set aDocument = Nothing
End Sub
即使已经设置了签名档，使用NotesSession发送邮件时，邮件中仍然没有包括签名档，需要读取签名档内容并添加到正文中。这里只是读取文本内容的签名档。


15. 发送带附件的邮件
Sub SendEmailbyNotesWithAttachement()
    Dim nNotes As Object
    Dim nDatabase As Object
    Dim nDocument As Object
    Dim nRTItem As Object
    Dim aSend As Variant
   
    On Error GoTo errHandle
    ' 使用数组表示多个接收者
    aSend = VBA.Array("test1@xxx.com", "test2@xxx.com")
    Set nNotes = CreateObject("Notes.NotesSession")
    Set nDatabase = nNotes.CURRENTDATABASE
    Set nDocument = nDatabase.CREATEDOCUMENT
    nDocument.Subject = "Test"
    nDocument.SendTo = aSend
    nDocument.Form = "Memo"
    nDocument.SAVEMESSAGEONSEND = True
    nDocument.PostedDate = Now
    Set nRTItem = nDocument.CREATERICHTEXTITEM("Body")
    Call nRTItem.AddNewLine(2)
    Call nRTItem.AppendText("This is a test mail with a attachement")
    Call nRTItem.AddNewLine(1)
    Call nRTItem.EMBEDOBJECT(1454, "", "c:\test.txt")
    Call nDocument.SEND(False)
    Set nNotes = Nothing
    Set nDatabase = Nothing
    Set nDocument = Nothing
    Set nRTItem = Nothing
    Exit Sub
errHandle:
    Set nNotes = Nothing
    Set nDatabase = Nothing
    Set nDocument = Nothing
    Set nRTItem = Nothing
    MsgBox Err.Description
End Sub

如果在Set nRTItem语句前设置nDocument.Body属性，代码将出错并提示“Rich text item body already exists”错误。下面的代码将出错。
    Set nDocument = nDatabase.CREATEDOCUMENT
    nDocument.Subject = "Test"
    nDocument.SendTo = aSend
    nDocument.Form = "Memo"
    nDocument.SAVEMESSAGEONSEND = True
    nDocument.PostedDate = Now
    nDocument.body = "This is a test using body"
    Set nRTItem = nDocument.CREATERICHTEXTITEM("Body")

这时可以修改Set nRTItem语句来创建另外一个名称的RichText Item。如下:
    Set nDocument = nDatabase.CREATEDOCUMENT
    nDocument.Subject = "Test"
    nDocument.SendTo = aSend
    nDocument.Form = "Memo"
    nDocument.SAVEMESSAGEONSEND = True
    nDocument.PostedDate = Now
    nDocument.body = "This is a test using body"
    Set nRTItem = nDocument.CREATERICHTEXTITEM("Body1")
但是这样的结果是RichText Item中AppendText的内容不能显示，仅能显示附件。

也可以将Set nRTItem语句移动到前面，如下：
    Set nDocument = nDatabase.CREATEDOCUMENT
    Set nRTItem = nDocument.CREATERICHTEXTITEM("Body")
    nDocument.Subject = "Test"
    nDocument.SendTo = aSend
    nDocument.Form = "Memo"
    nDocument.SAVEMESSAGEONSEND = True
    nDocument.PostedDate = Now
    nDocument.body = "This is a test using body"
代码仍能运行，同上例一样RichText Item中AppendText的内容不能显示，仅能显示附件。
这个方法有一个问题是正文中有两个相同名称的Item，一个是Text类型的Item，另外一个是RichText类型的Item。而Lotus的程序也是很奇怪，有GetFirstItem但没有GetNextItem。使用程序方法的话，程序限制只能获取第一个Item的内容，也就是Text类型的Item。要想获取第2个Item的内容，需要先删除第一个Item，然后保存Document，然后再使用GetFirstItem方法获取第2个 Item（现在是第1个了）的附件。所以建议不要使用相同名称的Item。

17. 选择工作表范围发送邮件
Sub SendRange()
    Dim nNotes As Object
    Dim nDatabase As Object
    Dim nDocument As Object
    Dim aSend As Variant
    Dim rngSel As Range
    Dim doClip As DataObject
   
    Set rngSel = Application.InputBox("请选择工作表范围:", "选择", , , , , , 8)
    If rngSel Is Nothing Then Exit Sub
    ' 复制单元格内容到剪贴板
    rngSel.Copy
    Set doClip = New DataObject
    doClip.GetFromClipboard
    Application.CutCopyMode = False
   
    On Error GoTo errHandle
    aSend = VBA.Array("test1@xxx.com", "test2@xxx.com")
    Set nNotes = CreateObject("Notes.NotesSession")
    Set nDatabase = nNotes.CURRENTDATABASE
    Set nDocument = nDatabase.CREATEDOCUMENT
    nDocument.Subject = "Test"
    nDocument.SendTo = aSend
    nDocument.Form = "Memo"
    nDocument.body = "This is test which include a range selection from Excel" & vbCrLf & doClip.GetText
    nDocument.SAVEMESSAGEONSEND = True
    nDocument.PostedDate = Now
   
    Call nDocument.SEND(False)
    Set nNotes = Nothing
    Set nDatabase = Nothing
    Set nDocument = Nothing
    Set dtClip = Nothing
    Exit Sub
errHandle:
    Set nNotes = Nothing
    Set nDatabase = Nothing
    Set nDocument = Nothing
    Set dtClip = Nothing
    MsgBox Err.Description
End Sub

18. 将选择内容以图片方式发送
Sub SendFormatData()
    Dim aNotesUI
    Dim aDocUI
    Dim strTo As String
    Dim strCC As String
    Dim strSub As String
    Dim strBody As String
    Dim rngSel As Range
   
    Set rngSel = Application.InputBox("请选择工作表范围:", "选择", , , , , , 8)
    If rngSel Is Nothing Then Exit Sub
    rngSel.Copy
   
    Set aNotesUI = CreateObject("Notes.NotesUIWorkspace")
    Set aDocUI = aNotesUI.COMPOSEDOCUMENT("", "c:\work\temp.nsf", "Memo")
    Set aDocUI = aNotesUI.CURRENTDOCUMENT
    strTo = "test1@xxx.com"
    strCC = "test2@xxx.com"
    strSub = "test"
    strBody = "Here is a test with picture from Excel"

    ' 设置Field的内容
    Call aDocUI.FIELDSETTEXT("EnterSendTo", strTo)        ' 收件人
    Call aDocUI.FIELDSETTEXT("EnterCopyTo", strCC)      ' CC
    Call aDocUI.FIELDSETTEXT("Subject", strSub)         ' 主题
   
    ' 添加正文内容
    Call aDocUI.FIELDAPPENDTEXT("Body", vbCrLf & strBody & vbCrLf)

    ' 将选择的内容复制到正文中
    Call aDocUI.GOTOFIELD("Body")
    Call aDocUI.Paste

    ' 保存邮件
    Call aDocUI.Save
   
    ' 发送邮件
    'Call aDocUI.Send(True)

    Application.CutCopyMode = False
    Set aDocUI = Nothing
    Set aNotesUI = Nothing
    Set rngSel = Nothing   
End Sub
FieldSetText方法是设置文档中指定Field（也可以说是Item）的值，如果该Field中已经存在内容，则被覆盖。
FieldAppendText方法是在文档中指定的Field上添加内容，而不去除已有内容。

如果复制图表的话，可以将
Set rngSel = Application.InputBox("请选择工作表范围:", "选择", , , , , , 8)
If rngSel Is Nothing Then Exit Sub
rngSel.Copy
修改成：
If ActiveChart Is Nothing Then Exit Sub
ActiveChart.CopyPicture xlScreen, xlPicture, xlScreen

如果复制工作表中插入的图片的话，修改代码为（其中Shape需自己更改）为：
ActiveSheet.Shapes(2).Select
Selection.Copy

示例文件： Lotus Notes VBA Sample.zip (48.65 KB, 下载次数: 944)

2010-3-13 16:44 上传

点击文件名下载附件

[ 本帖最后由 winland 于 2010-3-13 16:50 编辑 ]

gwjkkkkk

不错不错不错

tonyibm

多谢版主，很有用，

aidixiao

感谢分享。

kegen911

非常有用，谢谢Winland！

test1147

不錯不錯
給它研究去了
感謝如此用心

hnsly

如果是想发送多个图片并且带附件,应该怎么实现呢?谢谢

winland

原帖由 hnsly 于 2010-5-7 14:57 发表
如果是想发送多个图片并且带附件,应该怎么实现呢?谢谢

这个应该将上面发送图片和带附件的代码组合一下就可以了吧。

EH2003

明天登陆服务器试。

smhf_6

使用VBA还能操作Lotus Notes？
过去我一直认为这是二个完全不相关的，根本没考虑，现在版主提供了一个这么好的示例，非常感谢。
不过我们单位现在在用的是8.0版本，但这应该没问题