编辑和发送 Lotus 邮件的 Excel/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