LotusScript 发送HTML格式邮件（Outlook）2
1 Sub Initialize2 Msgbox "h3c18001:SendTaskMail Start"
3 On Error Goto errormsg
4 Dim fldlst As New LCFieldList
5 Dim doc As NotesDocument
6 Dim sql As String, DocUrl As String, MainDocUNID As String, DocUNID As String
7 Dim Subject As String,HtmlBody As String
8 MainDocUNID = WF_Document.WF_DocUNID(0)
9 DocUrl = GetConfigById("HttpServer")
10 sql = |select * from bpm_dicdoclist where AppId='h3c18001' And FolderId='011' And XmlData.value('(/Items/WFItem[@name="MainDocID"])','nvarchar(max)')='|+MainDocUNID+|'|
11 msgbox sql
12 Call WF_Con.execute(sql,fldlst)
13 While WF_Con.fetch(fldlst)
14 Set doc = rdb.getTmpDoc(fldlst)
15 DocUNID = doc.WF_DocUNID(0)
16 SendTo = doc.implementer(0)
17 Subject = doc.Subject(0)
18 HtmlBody = |请及时完成任务单的交办任务<BR>|
19 HtmlBody = HtmlBody + |请点击链接打开文档：<a href="|+DocUrl+|/bpm/app.nsf/frmOpenForm?readform&WF_FormNumber=F_h3c18001_011.1&WF_DocUNID=|+DocUNID+|&WF_Action=Edit" target="_blank">打开文档</a><BR><BR>|
20 Call SendMail(doc,SendTo,"",Subject,HtmlBody,"")
21 Wend
22 Msgbox "h3c18001:SendTaskMail Start"
23 Exit Sub
24 errormsg:
25 Msgbox "Rule Error:" & Str(Erl) & "" & Error
26 End Sub
27 function SendMail(tmpdoc As NotesDocument,SendTo As Variant,CopyTo As Variant,Subject As String,HtmlBody As String,FromName As String)
28 '替换标题
29 dim i As integer,lStr As string,rStr As string,mStr As string,vStr As string,maxnum As integer
30 i=InStr(Subject,"{")
31 While i>0 And maxnum<20
32 maxnum=maxnum+1
33 lStr=StrLeft(Subject,"}")
34 mStr=StrRight(lStr,"{")
35 lStr=StrLeft(lStr,"{")
36 rStr=StrRight(Subject,"}")
37 vStr=ArrayToStr(tmpdoc.GetItemValue(mStr),",")
38 Subject=lStr+vStr+rStr
39 i=InStr(rStr,"{")
40 Wend
41 '替换内容
42 Dim HttpServer As String,Folder as string,DocUrl as string
43 Folder=StrLeftBack(Replace(tmpdoc.parentdatabase.filepath,"/","\"),"\")
44 HttpServer=GetConfigById("HttpServer")
45 DocUrl=HttpServer+"/"+Folder+"/frmOpenForm?readform&WF_FormNumber="+tmpdoc.WF_FormNumber(0)+"&WF_DocUNID="+tmpdoc.WF_DocUNID(0)
46 HtmlBody=Replace(HtmlBody,"{doclink}","<a href='"+DocUrl+"' target='_blank' >"+tmpdoc.Subject(0)+"</a>")
47 HtmlBody=Replace(HtmlBody,"{systemlink}","<a href='"+GetConfigById("System_Url")+"' target='_blank' >"+GetConfigById("System_Name")+"</a>")
48 HtmlBody=Replace(HtmlBody,Chr(13)&Chr(10),"<br>")
49 maxnum=0
50 i=InStr(HtmlBody,"{")
51 While i>0 And maxnum<20
52 lStr=StrLeft(HtmlBody,"}")
53 mStr=StrRight(lStr,"{")
54 lStr=StrLeft(lStr,"{")
55 rStr=StrRight(HtmlBody,"}")
56 vStr=ArrayToStr(tmpdoc.GetItemValue(mStr),",")
57 HtmlBody=lStr+vStr+rStr
58 i=InStr(rStr,"{")
59 Wend
60 '内容替换结束
61 Dim s as new NotesSession
62 dim db as notesdatabase
63 dim doc as notesdocument
64 dim body as NotesMIMEEntity
65 dim header as NotesMIMEHeader
66 dim stream as NotesStream
67 set db = s.CurrentDatabase
68 set stream = s.CreateStream
69 s.ConvertMIME= False' do not convert MIME to rich text
70 set doc = db.CreateDocument
71 doc.Form = "Memo"
72 doc.SendTo=SendTo
73 doc.CopyTo=CopyTo
74 doc.Subject=Subject
75 doc.Principal=FormName
76 doc.InetForm=FormName
77 doc.TMPDISPLAYFORM_PREVIEW=FormName
78 doc.TMPDISPLAYFORM_NOLOGO=FormName
79 set body = doc.CreateMIMEEntity
80 set header = body.CreateHeader({MIME-Version})
81 call header.SetHeaderVal("1.0")
82 set header = body.CreateHeader("Content-Type")
83 call header.SetHeaderValAndParams({multipart/alternative;boundary="=NextPart_="})
84 call stream.writetext(|<HTML>|)
85 call stream.writetext(|<body bgcolor="white">|)
86 call stream.writetext(|<font size="2">|)
87 call stream.writetext(HtmlBody)
88 call stream.writetext(|</font>|)
89 call stream.writetext(|</body>|)
90 call stream.writetext(|</HTML>|)
91 body.SetContentFromText stream,"text/html;charset=UTF-8",ENC_NONE
92 call doc.Send(False)
93 s.ConvertMIME = True 'Restore conversion - very important
94
95 end function
页:
[1]