以前发过一个编辑和发送Outlook邮件的Excel/VBA脚本。最近公司不让用Outlook，强制使用IBM Lotus Notes，我又写了一个编辑和发送Lotus邮件的VBA脚本。
这个脚本可以自动为你写好邮件收件人、标题、正文内容，并粘贴上附件，最后停留在待发送的状态。
具体使用方法参见以下代码前面的注释。
' 通过Lotus发送邮件'' SendMailWithLotus(vaRecipient, emailTitle, emailBody, attachments, sentOut, sheetRange)'' vaRecipient：接收人列表，为一个字符串；或者为字符串数组(下表从0开始)，数组第一个元素' 为接收人名单，第二个元素(若有)为抄送人名单，第三个元素(若有)为暗送人名单' emailTitle：邮件标题' emailBody：邮件正文，目前只支持文本' attachments：为一个数组，数组每个元素都是各个附件的文件名(带路径)' sentOut：是否自动发送。默认为不自动发送，Lotus会停留在待发送界面' sheetRange：一个Excel.Range对象，Lotus会把该区域粘贴到邮件内容里。'' Author: zhang@zhiqiang.org, version: 2012-09-23' url: http://zhiqiang.org/blog/it/send-email-with-lotus.htmlPublic Function SendMailWithLotus( _ Optional vaRecipient As Variant = "zhang@zhiqiang.org", _ Optional emailTitle As String = "Test VBA with Lotus", _ Optional emailBody As String = "", Optional vaFiles As Variant, _ Optional sentOut = False, Optional sheetRange = "") Dim noSession As Object, noDatabase As Object, noDocument As Object Dim noAttachment As Object, i As Long Dim richTextBody As Object, tempObject As Object, ws As Object Const EMBED_ATTACHMENT = 1454 ' 如果需要手动选取附件，保留下面一行语句 ' vaFiles = Application.GetOpenFilename(FileFilter:= _ ' "Excel Filer (*.xls),*.xls", _ ' Title:="Attach files for outgoing E_Mail", MultiSelect:=True) ' If Not IsArray(vaFiles) Then Exit Function Set noSession = CreateObject("Notes.NotesSession") Set ws = CreateObject("Notes.NotesUIWorkspace") Set noDatabase = noSession.GETDATABASE("", "") If noDatabase.IsOpen = False Then noDatabase.OPENMAIL Set noDocument = noDatabase.createdocument Set noAttachment = noDocument.CREATERICHTEXTITEM("attachment") Set richTextBody = noDocument.CREATERICHTEXTITEM("Body") If IsArray(vaFiles) Then With noAttachment For i = LBound(vaFiles) To UBound(vaFiles) .EmbedObject EMBED_ATTACHMENT, "", vaFiles(i) Next i End With End If With noDocument .Form = "Memo" If IsArray(vaRecipient) Then .sendto = vaRecipient(0) If UBound(vaRecipient) >= 1 Then .CopyTo = vaRecipient(1) End If If UBound(vaRecipient) >= 2 Then .BlindCopyTo = vaRecipient(2) End If Else .sendto = vaRecipient End If .subject = emailTitle .SAVEMESSAGEONSEND = True .PostedDate = Now() - 100 ' .SEND 0, vaRecipient End With Dim uidoc As Object Set uidoc = ws.EDITDOCUMENT(True, noDocument) If IsObject(sheetRange) Then Call uidoc.GOTOFIELD("Body") sheetRange.Copy uidoc.Paste End If Call uidoc.GOTOFIELD("Body") uidoc.INSERTTEXT emailBody & vbCrLf & vbCrLf Call uidoc.Save noDocument.Save True, True If sentOut Then Call uidoc.Close noDocument.send True ' 这里不太好使，原因未知 End If Set noDocument = Nothing Set noDatabase = Nothing Set noSession = Nothing Set ws = Nothing Set tempObject = Nothing Set uidoc = Nothing Set richTextBody = Nothing ' MsgBox "This file is send OK", vbInformationEnd Function强国说学习qiangguoshuo.com
转载声明：本站发布文章及版权归原作者所有，转载本站文章请注明文章来源！
