LotusScript 发送HTML格式邮件（Outlook）1
1 Sub Initialize2 On Error Goto errormsg
3 Msgbox "RUh3c18001_011:SendMailOfReview Start"
4 Dim sql As String
5 Dim doc As NotesDocument
6 Dim docunid As Variant
7 Dim i As Integer, n As Integer
8 Dim tr As String, table As String, HTMLBody As String, mailsend As String
9 Dim ProcessUNID As String
10 ProcessUNID = "B994EBB76C5F586648257DC4002AB3BB"
11 docunid = Split(WF_Document.docunid(0), ",")
12 n = Ubound(docunid)
13 mailsend = GetSendTo
14 msgbox mailsend
15 If mailsend = "" Then
16 Print "Context-Type:application/text;charset=UTF-8"
17 Print "没有找到邮件接收人,请检查配置文档！"
18 Exit Sub
19 End If
20 table = "<Table style='BORDER-COLLAPSE: collapse' border=1>"
21 table = table + InitTable
22 For i = 0 To n
23 sql = |select * from BPM_DicDocList where WF_DocUNID = '|+docunid(i)+|'|
24 Set doc = rdb.GetDocumentBySql(sql)
25 If Not doc Is Nothing Then
26 table = table + InitTR(doc, ProcessUNID)
27 End If
28 Next
29 table = table + "</Table>"
30 HTMLBody = "1、变更评审清单：<BR>" + table
31 HTMLBody = HTMLBody + "<BR><BR>2、如果您认为以上变更只需发起邮件评审，请在今天10：30前邮件反馈我，谢谢！"
32 SendTo = Split(mailsend, ",")
33 Call SendMail(SendTo, "变更申请", HTMLBody)
34 Msgbox "RUh3c18001_011:SendMailOfReview End"
35 Print "Context-Type:application/text;charset=UTF-8"
36 Print "OK"
37 Exit Sub
38 errormsg:
39 Msgbox "Rule Error:" & Str(Erl) & "" & Error
40 End Sub
41 Function GetSendTo() As String
42 Dim sql As String
43 Dim confdoc As NotesDocument
44 sql = |select top 1 * from BPM_DicDocList where AppId = 'h3c18001' and FolderId = '003'|
45 Set confdoc = rdb.GetDocumentBySql(sql)
46 If Not confdoc Is Nothing Then
47 GetSendTo = confdoc.meeting(0)
48 Else
49 GetSendTo = ""
50 End If
51 End Function
52 Function SendMail(SendTo As Variant,Subject As String,HTMLBody As String)
53 Dim se As New NotesSession
54 Dim db As NotesDatabase
55 Dim maildoc As NotesDocument
56 Dim body As NotesMIMEEntity
57 Dim header As NotesMIMEHeader
58 Dim stream As NotesStream
59 Set db = se.CurrentDatabase
60 Set stream = se.CreateStream
61 Set maildoc = db.CreateDocument
62 Maildoc.Form = "Memo"
63 Maildoc.Subject = Subject
64 Maildoc.SendTo = SendTo
65 Set body = Maildoc.CreateMIMEEntity
66 'Set header = body.CreateHeader("To")
67 'Call header.SetHeaderVal("guojian KF3530")
68 Call stream.writetext(|<HTML>|)
69 Call stream.writetext(|<body>|)
70 Call stream.writetext(HTMLBody)
71 Call stream.writetext(|</body>|)
72 Call stream.writetext(|</HTML>|)
73 Call body.SetContentFromText(stream,"text/HTML;charset=UTF-8",ENC_NONE)
74 Call maildoc.Send(False)
75 se.ConvertMIME = True
76 End Function
77 Function InitTable() As String
78 Dim table As String
79 table = "<TR>"
80 table = table + "<TD>电子流号</TD>"
81 table = table + "<TD>主题</TD>"
82 table = table + "<TD>状态</TD>"
83 table = table + "<TD>当前处理人</TD>"
84 table = table + "<TD>申请人</TD>"
85 table = table + "<TD>申请时间</TD>"
86 table = table + "</TR>"
87 InitTable = table
88 End Function
89 Function InitTR(doc As NotesDocument,ProcessUNID As String) As String
90 Dim HStr As String
91 Dim DocUrl As String, sql As String
92 Dim MainDoc As NotesDocument
93 Dim docStatus As String,curUser As String
94 DocUrl = GetConfigById("SendMailDocUrl")
95 DocUrl = Replace(DocUrl,"{ProcessUNID}",ProcessUNID)
96 DocUrl = Replace(DocUrl,"{DocUNID}",doc.MainDocId(0))
97 docStatus = ""
98 curUser = ""
99 sql = |select top 1 * from BPM_AllDocument where WF_DocUNID = '| + doc.MainDocId(0) + |' |
100 Set MainDoc = rdb.GetDocumentBySql(sql)
101 If Not MainDoc Is Nothing Then
102 docStatus = MainDoc.WF_CurrentNodeName(0)
103 curUser = MainDoc.WF_Author(0)
104 End If
105 HStr = "<TR>"
106 HStr = HStr + "<TD>" + doc.DocNo(0) + "</TD>"
107 HStr = HStr + "<TD><a href='" + DocUrl + "'>" + doc.Subject(0) + "</a></TD>"
108 HStr = HStr + "<TD>" + docStatus + "</TD>"
109 HStr = HStr + "<TD>" + curUser + "</TD>"
110 HStr = HStr + "<TD>" + doc.applyer(0) + "</TD>"
111 HStr = HStr + "<TD>" + doc.applytime(0) + "</TD>"
112 HStr = HStr + "</TR>"
113 InitTR = HStr
114 End Function
页:
[1]