LotusScript 发送HTML格式邮件（Outlook）1

最新推荐文章于 2017-02-27 09:39:59 发布

weixin_30672019

最新推荐文章于 2017-02-27 09:39:59 发布

阅读量156

点赞数

原文链接：http://www.cnblogs.com/guojian2080/p/4342108.html

版权

  1 Sub Initialize
  2     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

转载于:https://www.cnblogs.com/guojian2080/p/4342108.html

weixin_30672019

关注

0
点赞
踩
1

收藏

觉得还不错? 一键收藏
0
评论
LotusScript 发送HTML格式邮件（Outlook）1

1 Sub Initialize 2 On Error Goto errormsg 3 Msgbox "RUh3c18001_011:SendMailOfReview Start" 4 Dim sql As String 5 Dim doc As NotesDocument 6 Dim docunid As Varian...
复制链接

扫一扫