编辑和发送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会把该区域粘贴到邮件内容里。
'
' 
' url: /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 多表合并和查询是一个应用很广泛的问题。下面是一个简单的例子,我们需要从两张数据表里,得出每个行业的股票波动率平均值。第一个数据表保存了股票和行业的对应关系,有两列,第一列为股票名,第二列为每只股票对应的行业。第二张表保存了各个股票在各个交易日的收盘价和前收盘价,有四列,第一列是股票名,第二列为交易日,第三列和第四列分别为股票在这个交易日的前收盘价和收盘价。
2014-03-25 更新:我已经将该类修改成函数形式,并增加新功能,参见 更新 Excel 的数据库查询函数库
Excel 多表合并和查询是一个应用很广泛的问题。下面是一个简单的例子,我们需要从两张数据表里,得出每个行业的股票波动率平均值。第一个数据表保存了股票和行业的对应关系,有两列,第一列为股票名,第二列为每只股票对应的行业。第二张表保存了各个股票在各个交易日的收盘价和前收盘价,有四列,第一列是股票名,第二列为交易日,第三列和第四列分别为股票在这个交易日的前收盘价和收盘价。
2014-03-25 更新:我已经将该类修改成函数形式,并增加新功能,参见 更新 Excel 的数据库查询函数库