编辑和发送Lotus邮件的Excel/VBA脚本

作者:, 发表于

办公自动化

查看该系列所有文章

以前发过一个编辑和发送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.html
Public 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", vbInformation
End Function

Q.E.D.


上一篇:Excel数据源的多表合并和SQL查询2012年9月3日
Excel多表合并和查询是一个应用很广泛的问题。下面是一个简单的例子,我们需要从两张数据表里,得出每个行业的股票波动率平均值。第一个数据表

下一篇:封装ADODB数据库查询的Excel VBA类模块2012年9月28日
2014-03-25 更新:我已经将该类修改成函数形式,并增加新功能,参见更新Excel的数据库查询函数库。 关于Excel操纵数据库,我在前面至少写过两篇相关


  • 支持使用微薄、微信和QQ的账户登陆进行评论。由各自网站直接认证,不会泄露你的密码。
  • 登陆后可选择分享评论到所绑定的社交网络,如微薄、人人和QQ空间。
  • 评论提交后无法修改。如需修改,请删除原评论再重新提交。
  • 评论支持LaTeX代码,行内公式请用\(a+b=c\),行间公式请用\[a+b=c\]。公式只支持英文字符。