用VBA操纵Lotus notes发邮件

287 , 用lotus notes发送邮件，

第一种方法，

Sub SendWithLotus()

Dim noSession As Object, noDatabase As Object Dim noDocument As Object, noAttachment As Object Dim FileSelf As String Dim i As Long

Const EMBED_ATTACHMENT = 1454

Const stSubject As String = \Dim stMsg As String

FileSelf = ThisWorkbook.Path + \stMsg = \

Application.UserName & vbCrLf & _ vbCrLf & _

\ \

Dim vaRecipient As Variant

vaRecipient = VBA.Array(\ 'Insert Lotus Notes COM object.

Set noSession = CreateObject(\

Set noDatabase = noSession.GETDATABASE(\ If noDatabase.IsOpen = False Then noDatabase.OPENMAIL Set noDocument = noDatabase.CREATEDOCUMENT

Set noAttachment = noDocument.CREATERICHTEXTITEM(\ noAttachment.EMBEDOBJECT EMBED_ATTACHMENT, \

With noDocument .Form = \ .SendTo = vaRecipient .Subject = stSubject .Body = stMsg

.SAVEMESSAGEONSEND = True .PostedDate = Now() .SEND 0, vaRecipient End With

Set noDocument = Nothing Set noDatabase = Nothing Set noSession = Nothing AppActivate \

MsgBox \

End Sub

第二种方法

Sub SendWithLotus()

Dim noSession As Object, noDatabase As Object Dim noDocument As Object, noAttachment As Object Dim vaFiles As Variant Dim i As Long

Const EMBED_ATTACHMENT = 1454

Const stSubject As String = \

Const stMsg As String = \Dim vaRecipient As Variant

vaRecipient = VBA.Array(\

vaFiles = Application.GetOpenFilename(FileFilter:=\Filer (*.xls),*.xls\Title:=\files for outgoing E_Mail\MultiSelect:=True)

If Not IsArray(vaFiles) Then Exit Sub 'Insert Lotus Notes COM object.

Set noSession = CreateObject(\

Set noDatabase = noSession.GETDATABASE(\ If noDatabase.IsOpen = False Then noDatabase.OPENMAIL Set noDocument = noDatabase.CREATEDOCUMENT

Set noAttachment = noDocument.CREATERICHTEXTITEM(\ With noAttachment

For i = 1 To UBound(vaFiles)

.EMBEDOBJECT EMBED_ATTACHMENT, \ Next i End With With noDocument .Form = \ .SendTo = vaRecipient .Subject = stSubject .Body = stMsg

.SAVEMESSAGEONSEND = True .PostedDate = Now() .SEND 0, vaRecipient End With

Set noDocument = Nothing Set noDatabase = Nothing Set noSession = Nothing AppActivate \

MsgBox \ OK\End Sub

1, 返回当前数据库的信息，

a, 返回当前数据库的名称，

结果，

b, 返回当前数据库的文件名，

c, 返回当前数据库的文件路径，

2，发送邮件的一些设置，

Sub aaaaaa()

Dim no As Object Dim db As Object Dim doc As Object Dim fields As Object Dim nofields As Object Dim att As Variant

att = Application.GetOpenFilename(FileFilter:=\Title:=\添加附件

Set no = CreateObject(\建立和邮件的连接 Set db = no.CURRENTDATABASE '建立和邮件数据库的连接 Set doc = db.CREATEDOCUMENT '创建一个新的邮件

Set fields = doc.CREATERICHTEXTITEM(\设置新邮件的正文（附件）对象

With fields '设置邮件的正文和附件

.APPENDTEXT \ this e-mail is generated by an automated process just for a test\ .ADDNEWLINE 1 '增加第一行

.APPENDTEXT \ please do not reply.\ .ADDNEWLINE 2 '增加第二行

For i = 1 To UBound(att) '添加附件

.EMBEDOBJECT 1454, \ Next i End With

With doc '设置新邮件的除正文和附件外的其他信息

.form = \新邮件

.sendto = VBA.Array(\发送给 .Subject = \主题

.SAVEMESSAGEONSEND = True '是否保存发送的邮件到发件箱 .postdate = DateAdd(\发送日期等于当天 .SEND 0 '发送 End With

MsgBox \

Set no = Nothing '释放内存 Set db = Nothing Set doc = Nothing Set fields = Nothing End Sub

在添加附件的时候，如果只是想将当前的活动工作薄作为附件的话，如下，

注意一下, 如果是1452的话, 效果如下,

会出现一个提示, 询问文档包含外部对象链接, 是否要更新链接, 如果确定的话, 效果如下, 会将EXCEL文件中的内容以图片形式打开, 同时文件是只读格式的,

如果是1453, 效果如下, 不会有提示, 但是文件为只读,

如果为1454, 则为正常的EXCEL文件格式,

3, 提取邮件的一些信息，

以上的发件人，发送时间，主题等信息还可以如下表示，

运行结果，

4，指定是在收件箱，发件箱或其他自定义的文件夹， a, 收件箱等邮箱本身就存在的，

b, 如果是自己创建的文件夹及子文件夹，

比如在我的邮箱中有自定义的文件夹，folders, 如果要想获取其下面的子文件夹之一的相关资料，则应如下书写，

4, 用上面的方法提取出来的发件人是有公司名称的，

anotes.CREATENAME(adocument.GETITEMVALUE(\如果不使用abbreviated, 则结果为，

如果想要输出的发件人只有名字，没有公司名的话，可以做如下更改，

结果为，

排版之后的效果如下所示，

5, 如果想要将附件保存到指定的文件夹的话，

以上代码是将发件箱中的附件保存到D盘的新建文件夹，

以下将发件箱改成自定义的文件夹，”HR － information”

6, 用以下方法也可以获得附件的名称，

结果，

也可以将oemb.source改成oemb.name, 结果一样，

结果，

以上代码是获取发件箱中的第一个邮件的附件名称，

7, 设置发送邮件时的邮件正文，

以上的代码中，其实with fields和with doc都是设置邮件的正文， with fields, 是设置邮件的正文和附件信息，

with doc, 是设置邮件的发送人，是否保存到发件箱等一些其他的信息，

8, 在发送邮件的时候，要注意body的问题，

a, 如果自始至终都使用body来添加附件和正文的话，则添加的正文就不会出现，就只有附件，

发送后的结果，

注意，以上发送出去的邮件是没有正文的，只有附件，就是说以上的代码用with doc添加的body正文没有添加成功， 如果想要有正文的话，有两个办法， 第一，

将第一个括号里面的body改成和第三个红框里面的body不同的字符，

结果，

注意，这样更改后的结果就是，发送的邮件的正文文本和附件之间有一条线分隔，

第二种方法， 就是用appendtext方法添加空行的方法，

以上的代码就是通过添加空行，添加文本的方法来添加正文文本部分， 结果，

9, 枚举所有folder的名称，

结果，

以上代码是返回所有的文件夹， 以下的代码返回的是非文件夹，

结果，

10, 如果想要将发件人的名称改成其他的名称，比如group sender, 可以做如下设置，

请注意以上代码中的红色框框部分，加上doc.principal = “group sender”， 收到的邮件的发件人就会显示group sender, 结果，

11, 如果在没有打开邮箱的情况下想发送邮件，可以设置如下

Sub abb()

Dim Maildb As Object Dim MailDoc As Object Dim Body As Object Dim Session As Object 'Start a session to notes

Set Session = CreateObject(\

'This line prompts for password of current ID noted in Notes.INI Call Session.Initialize

'or use below to supply password of the current ID 'Call Session.Initialize(\'Open the mail database in notes

Set Maildb = Session.GETDATABASE(\If Not Maildb.IsOpen = True Then Call Maildb.Open End If

'Create the mail document

Set MailDoc = Maildb.CREATEDOCUMENT

Call MailDoc.REPLACEITEMVALUE(\'Set the recipient

Call MailDoc.REPLACEITEMVALUE(\'Set subject

Call MailDoc.REPLACEITEMVALUE(\'Create and set the Body content

Set Body = MailDoc.CREATERICHTEXTITEM(\Call Body.APPENDTEXT(\'Example to create an attachment (optional) Call Body.ADDNEWLINE(2)

Call Body.EMBEDOBJECT(1454, \'Example to save the message (optional) MailDoc.SAVEMESSAGEONSEND = True 'Send the document

'Gets the mail to appear in the Sent items folder Call MailDoc.REPLACEITEMVALUE(\Call MailDoc.SEND(False) 'Clean Up

Set Maildb = Nothing Set MailDoc = Nothing Set Body = Nothing Set Session = Nothing End Sub 结果，

首先会要求输入密码，

这样的话，不用打开lotus notes就可以发送邮件了

如果不想每次都手动的输入密码的话，可以如下设置， call session.initialize(“密码”)

Sub abb()

Dim Maildb As Object Dim MailDoc As Object Dim Body As Object Dim Session As Object

Set Session = CreateObject(\

Call Session.Initialize(\

Set Maildb = Session.GETDATABASE(\If Not Maildb.IsOpen = True Then Call Maildb.Open End If

Set MailDoc = Maildb.CREATEDOCUMENT

Call MailDoc.REPLACEITEMVALUE(\

Call MailDoc.REPLACEITEMVALUE(\

Call MailDoc.REPLACEITEMVALUE(\

Set Body = MailDoc.CREATERICHTEXTITEM(\Call Body.APPENDTEXT(\

Call Body.ADDNEWLINE(2)

Call Body.EMBEDOBJECT(1454, \

MailDoc.SAVEMESSAGEONSEND = True

Call MailDoc.REPLACEITEMVALUE(\Call MailDoc.SEND(False)

Set Maildb = Nothing Set MailDoc = Nothing Set Body = Nothing Set Session = Nothing

MsgBox \发送成功!\ End Sub

结果如下，

12, 如果想要设置发送邮件时候的抄送等信息，设置如下，

结果，

如果想要发送给多个收件人，则设置如下，

结果，

13, 如果想要在发出的邮件中添加当前的签名的话，可以设置如下，

其中，

如果当前的签名不是文本，而是图片的话，这句代码就会返回作为当前签名的图片的名称和存放地址，

说明我当前的签名图片是存放在D盘的photo1文件夹中的，图片名称为邮件， 如下，

最后发送出去的结果如下所示，

可以看到，签名在此时就是图片的地址，因为其不是一段文本，所以才会这样， 而如果签名为文本的时候，效果如下，

以上就是上面这句代码返回的文本签名的内容， 发送出去的邮件如下所示，

14, 如果想要进行正文文本的排版的话（即分段隔行等），设置如下，

注意几个地方，

一个是addnewline, 在一句话完了之后的第一个vbnewline是起换行的作用，而第二个vbnewline才是新添加一个空行，

二个是在这种情况下，如果通过doc的body属性添加正文文本的话，则在声明fields的时候，不能也使用body, 要使用不同于body的名字， 效果如下，

要达到同样的效果，还有一种方法，

请注意，上面的代码中，有addnewline，在其后面的数字表示添加的行数，一般如果是隔行的话，则要添加两行，一行起换行作用，一行为添加的空行， 最终效果如下，

15, 返回邮件服务器的名称，

结果，

结果，

16, 返回notes的用户名， 1,

结果，

2,

结果，

17, 打开一个新邮件，并且将光标移到发件人，抄送人，或正文等处

Sub aaa()

Dim anotes Dim aDataBase Dim aview

Dim itotal Dim adocument Dim ws Dim notesdoc

Set ws = CreateObject(\

Set anotes = CreateObject(\

Set aDataBase = anotes.GETDATABASE(\

Set notesdoc = aDataBase.CREATEDOCUMENT

Set uidoc = ws.EDITDOCUMENT(True, notesdoc)

Call uidoc.GOTOFIELD(\

End Sub

执行完以上的代码之后，光标会移到邮件的正文，处于编辑状态，

如果将body换成subject的话，光标就会处于收件人处，

18, 如何根据工作表中多个邮箱地址发邮件，

Sub 发送邮件()

Dim Maildb As Object Dim MailDoc As Object Dim Body As Object Dim Session As Object Dim att Dim arr

x = Sheets(1).Range(\ReDim arr(1 To x)

For y = 1 To x

arr(y) = Sheets(1).Cells(y, 1) Next y

att = Application.GetOpenFilename(FileFilter:=\Title:=\添加附件

Set Session = CreateObject(\

Session.Initialize (\

Set Maildb = Session.GETDATABASE(\

If Not Maildb.IsOpen = True Then Call Maildb.Open End If

Set MailDoc = Maildb.CREATEDOCUMENT

Call MailDoc.REPLACEITEMVALUE(\

Call MailDoc.REPLACEITEMVALUE(\

Call MailDoc.REPLACEITEMVALUE(\

Set Body = MailDoc.CREATERICHTEXTITEM(\Call Body.APPENDTEXT(\

Call Body.ADDNEWLINE(2)

For i = 1 To UBound(att)

Call Body.EMBEDOBJECT(1454, \ Next i

MailDoc.SAVEMESSAGEONSEND = True

Call MailDoc.REPLACEITEMVALUE(\Call MailDoc.SEND(False)

Set Maildb = Nothing Set MailDoc = Nothing Set Body = Nothing Set Session = Nothing

MsgBox \发送成功!\ End Sub 结果，

19, 如何用VBS发邮件，

Dim mydocu , os , myBody

Set os = CreateObject(\

Set myDocu = os.CURRENTDATABASE.CREATEDOCUMENT Set myBody = myDocu.CREATERICHTEXTITEM(\

with mybody

.appendtext \ .addnewline 2

.embedobject 1454,\桌面\\overhead group.xls\

end with

with mydocu

.SendTo = \ .CopyTo = \

.Subject = \ .SEND 0

end with

msgbox \发送邮件成功!\提示\

Set myDocu = Nothing Set myBody = Nothing Set os = Nothing

发送方法，

双击VBS图标即可，

20, 如何将excel的部分内容作为richtext格式粘贴在邮件中, Sub aa()

Dim no As Object Dim db As Object

Dim clipboard As DataObject Dim doc As Object Dim field As Object

Set no = CreateObject(\建立和邮件的连接 Set db = no.CurrentDatabase Set doc = db.CreateDocument

Set field = doc.CreateRichTextItem(\

Selection.Copy

Set clipboard = New DataObject clipboard.GetFromClipboard

With field

.AppendText \此邮件为系统自动发送，请不要回复，仅作为测试使用！\ .AddNewLine 2

.AppendText clipboard.GetText(1) End With

With doc

.form = \

.sendto = \ .Subject = \自动邮件\ .SaveMessageOnSend = True

.postdate = Now() .Send 0 End With

Selection(1).Select

Application.CutCopyMode = False End Sub

发送的效果如下图,

21, 在发送附件的时候要注意的问题,

以下的代码的目的是发送带附件的邮件, 但是有个问题值得注意: 下面的正文部分和收件人信息部分不能置换位置, 如果将收件人信息放在正文上方, 则发出的邮件正文部分为空白,

22, 如何避免在用循环发送多个邮件的时候, 出现所有的附件都集中在一个邮件中的情况,

如果以上面的代码发送邮件的话, 就会出现所有的邮件都集中在一个邮件中的情况, 效果如下,

原因为: VBA和Lotus notes执行不同步造成的, 因为当lotus notes还没有处理完前一个邮件的时候, VBA已经执行到下一个循环了,

解决办法: 执行完一个循环, 就将设置正文及标题信息的doc对象设置成nothing, 然后到下一个循环的时候, 再用set函数创建,

发送后的效果如下所示:

23, notesview的type值, ? ? ? ? ?

ACTIONCD (16) means saved action CD records; non-Computable; canonical form.

ASSISTANTINFO (17) means saved assistant information; non-Computable; canonical form. ATTACHMENT (1084) means file attachment. AUTHORS (1076) means authors. COLLATION (2).

Note This value is new with Release 6. ? ? ? ? ? ? ? ? ? ? ? ? ?

DATETIMES (1024) means date-time value or range of date-time values. EMBEDDEDOBJECT (1090) means embedded object.

ERRORITEM (256) means an error occurred while accessing the type. FORMULA (1536) means Notes formula. HTML (21) means HTML source text. ICON (6) means icon.

LSOBJECT (20) means saved LotusScript Object code for an agent. MIME_PART (25) means MIME support. NAMES (1074) means names.

NOTELINKS (7) means link to a database, view, or document. NOTEREFS (4) means reference to the parent document. NUMBERS (768) means number or number list. OTHEROBJECT (1085) means other object.

? ? ? ? ? ? ? ? ? ? ? ?

QUERYCD (15) means saved query CD records; non-Computable; canonical form. READERS (1075) means readers.

RFC822Text (1282) means RFC822 Internet mail text. RICHTEXT (1) means rich text. SIGNATURE (8) means signature. TEXT (1280) means text or text list.

UNAVAILABLE (512) means the item type isn't available. UNKNOWN (0) means the item type isn't known. USERDATA (14) means user data. USERID (1792) means user ID name.

VIEWMAPDATA (18) means saved ViewMap dataset; non-Computable; canonical form. VIEWMAPLAYOUT (19) means saved ViewMap layout; non-Computable; canonical form.

以下代码返回inbox中的最后一封邮件的body的类型,

Sub Click()

Dim session Dim db Dim view Dim doc Dim ent Dim fil Dim ite Dim doc1 Dim emb fil = 0 ite = 0 emb = 0

Set session = CreateObject(\

Set db = session.GETDATABASE(\ Set view = db.GetView(\ Set doc = view.getlastdocument Set doc1 = doc.getfirstitem(\

MsgBox doc1.Type

End sub

结果

24, notesdocument 和notesrichtextitem 在有附件时候的区别,

结果

也就是说, notesdocument 是支持hasembedded属性的，而notesrichtextitem 是不支持的,

同时, noteitem 也没有这个属性, 因为richtextitem是item的一种子类型,

注意以下的语句,

想通过以上的代码首先判断最后一封邮件中是否有附件，如果有，则依次返回其名称， 结果，

原因如下，

Unlike the EmbeddedObjects property in NotesRichTextItem, this property does not include file attachments, nor OLE/1 objects created in Notes Release 3.

This property does include OLE/2 and OLE/1 objects created in Notes Release 4. It also includes objects in the document that were originally embedded in the document's form. Such objects must have been activated, modified, and re-saved in order to be returned by this property (otherwise they remain a part of the form, not the document).

所以要想达到以上效果，要通过notesrichtextitem 对象, 即上面的代码中定义的doc1, 但是doc1没有hasembedded这个属性可以判断是否包括附件，

但是要判断是否包含附件，可以通过notesdocument 对象的的hasembedded属性，

结果，

25, item 中的element,

使用getfirstelement,

如果使用findfirstelement, 则有以下type,

26, 返回邮件正文(不包括签名), - 包括发件人，时间，收件人，抄送，主题，

Sub Click()

Dim session Dim db Dim view Dim doc Dim ent Dim fil Dim ite Dim doc1 Dim emb

Set session = CreateObject(\

Set db = session.GETDATABASE(\ Set view = db.GetView(\ Set doc = view.getlastdocument Set doc1 = doc.getfirstitem(\ Set ent = doc1.createnavigator

If ent.findfirstelement(4) Then Do

Set emb = doc1.createrange Call emb.setbegin(ent)

MsgBox emb.textparagraph

Loop Until Not ent.findnextelement(4) End If

End Sub 结果，

26, 关闭当前打开的邮件窗口, Sub a()

Dim workspace Dim uidoc Dim uidoc1

Set workspace = CreateObject(\ Set uidoc = workspace.Currentdocument

Call uidoc.Close End Sub 结果，

27, 如何返回当前打开邮件的相关信息,

返回正文部分,

发件人

收件人

抄送

秘密抄送

正文

另外一种返回此上信息的方法是通过notesdocument对象的getitemvalue方法，

返回正文，

和通过notesuidocument对象的fieldgettext方法相比, 优点在于: 返回的正文的文本格式没有变化, 28, 如何设置文字的格式- CREATERICHTEXTSTYLE Sub aaaaaa()

Dim no As Object Dim db As Object Dim doc As Object Dim fields As Object Dim nofields As Object Dim att As Variant

本文来源：https://www.bwwdw.com/article/aduo.html