把各个用户的信息发送到它的邮箱

莫悠悠

编辑和发送Lotus邮件的Excel/VBA脚本
作者：张志强， 发表于 2012年9月26日， 最后修改于 2012年9月26日


系列：办公自动化
查看该系列所有文章
以前发过一个编辑和发送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
我对能发送表附件的方法比较感兴趣

jjip123

学习学习！！！！！！！！！！！！

sunny_8848

留个记号，好好学习

q3698995

牛B啊。。。

fqqwan

太牛了 太厉害了 是我想要的

dengguanxi

请教老师：出现这个错误是什么原因？俺是office 2013，能否赐教一下？

lhdcxz

dengguanxi 发表于 2014-2-20 10:01
请教老师：出现这个错误是什么原因？俺是office 2013，能否赐教一下？

可能需要改后缀为“.xlsx”

sam.tan

每次都是Email.send ''发送这句报错-2147220973

dengguanxi

lhdcxz 发表于 2014-2-20 10:05
可能需要改后缀为“.xlsx”

错误显示

老师你好，把代码后缀名改成XLSX后仍然是这样，能否再赐教一下呢》

lhdcxz

dengguanxi 发表于 2014-2-21 09:34
老师你好，把代码后缀名改成XLSX后仍然是这样，能否再赐教一下呢》

把你下载后更改了的附件发上来看看。