【原创】代理群发邮件！（共享版）

wintellzbh

用代理群发邮件,Attendershow是多值域，其中可以是群组和个人。
思想是把群组人员拆开，合并，发邮件。邮件内容是一个培训计划的简单内容，加上一个链接，
链接到我原来的文档！
Sub Initialize
        On Error Goto Errorhandler
        'On Error Resume Next
       
        Dim s As New notessession
        Dim db As notesdatabase
        Dim vw As notesview
        Dim doc As notesdocument
        Dim namedoc As notesdocument
       
        Set doc = s.documentcontext
        Set db = s.getdatabase("","names.nsf")
        Set vw = db.getview("群组")
        Set namedoc = vw.getfirstdocument
       
        Dim U As Variant
        Dim temp As Variant
        Dim i As Integer
        Dim members As Variant
        Dim max As Variant
       
        U = doc.AttenderShow
        max = Ubound(U)
       
        '对reader域中的值进行搜索，是群组的拆开。
        For i = 0 To max
                While (Not namedoc Is Nothing)
                        '判断是否为群组
                        If U(i) = namedoc.listname(0) Then
                                members = namedoc.members
                                '用temp数组暂存拆开数组的个人用户，并把原来群组名删除
                                temp = Arrayappend(members,temp)
                                U(i) = ""
                        End If
                        Set namedoc = vw.getnextdocument(namedoc)
                Wend
                Set namedoc = vw.getfirstdocument
        Next
       
        U = Fulltrim(U)
        U = Arrayappend(U,temp)
        '调用函数ArrayUnique(U)，去除unread中的重复项
        U = ArrayUnique(U)
        Call SendMail(U)
       
Errorhandler:
        Print "Error" & Str$(Err) ":"& Error$
End Sub

Function ArrayUnique(Array As Variant) As Variant
        Dim i As Integer
        Dim j As Integer
        Dim max As Integer
        If Isarray(Array) Then
                max = Ubound(Array)       
                For i = 0 To max
                        For j=i+1 To max
                                If array(i) = array(j) Then
                                        array(j) = ""
                                End If
                        Next
                Next
                ArrayUnique = Fulltrim( array )
        Else
                ArrayUnique = array
        End If
End Function

Function SendMail(U As Variant) As Variant
        Dim max As Integer
        Dim i As Integer
        Dim AttenderName As Variant
        Dim s As New NotesSession
        Set doc = s.DocumentContext
        Set mailDB = New NotesDatabase(s.CurrentDatabase.Server, "mail.box")
        max = Ubound(U)
        For i = 0 To max
                AttenderName = U(i)
                Set mailDoc = mailDB.CreateDocument
               
                mailDoc.Form = "Memo"
                mailDoc.CopyTo = BlankArray
                mailDoc.BlindCopyTo = BlankArray
               
                mailDoc.From = doc.Author(0)
                mailDoc.ReplyTo = doc.Author(0)
                mailDoc.Recipients = AttenderName
                mailDoc.SendTo = AttenderName
                mailDoc.Subject = "新培训：" + doc.Subject(0)
               
                Set rtItem = mailDoc.CreateRichTextItem("Body")
                url = "/" + doc.DbPath(0) + "/0/" + doc.UniversalID + "?OpenDocument&INW=1"
               
                Call rtItem.AppendText("有新的培训计划邀请你参加！")
                Call rtItem.AddNewLine(1)
                Call rtItem.AppendText("[<a href="""+url+""" target=""blank"">"+"查看详细内容"+"</a>]")
                Call mailDoc.Save(True, False)
        Next
        Print "<script>document.location.replace(""/" + doc.DbPath(0) +_
        "/frmView?OpenForm&view="+doc.ViewName(0)+"&class="+doc.ClassName(0)+_
        "&path=""+escape("""+doc.Path(0)+""")+""&Start="+Cstr(doc.Start(0))+""")</script>"
End Function