" binary " ) Then MsgBox " Open failed " End If If stream.B

时间:2021-10-17 04:36:16

公司的邮件系统用的是反人类的 Lotus notes, 你敢信?

比来要实现一个成果,邮件提醒成果,就是通过自动发送提醒邮件

前前后后这个问题搞了2天,由于公司的诸多条件限制,无法直接挪用到公司发送邮件的接口,只有通过类似 Lotus script,VBA 等其他方法来实现。

用VBA代码实现发送邮件,其实我在n年前就实现过了

代码如下,网上一搜也一大堆

Function SendEmailbyNotesWithAttachement_2(Addresses, Attach, cc) strSubject = ThisWorkbook.Sheets("EMAIL").Range("B1") strbody = ThisWorkbook.Sheets("EMAIL").Range("A1") Declare Variables Dim s As Object Dim db As Object Dim body As Object Dim bodyChild As Object Dim header As Object Dim stream As Object Dim host As String Dim message As Object Notes variables Set s = CreateObject("Notes.NotesSession") Set db = s.CURRENTDATABASE Set stream = s.CreateStream Turn off auto conversion to rtf s.ConvertMIME = False Create message Set message = db.CREATEDOCUMENT message.Form = "memo" message.Subject = strSubject message.sendTo = Split(Addresses, ";") message.CopyTo = cc message.SaveMessageOnSend = True Create the body to hold HTML and attachment Set body = message.CreateMIMEEntity Child mime entity which is going to contain the HTML which we put in the stream Set bodyChild = body.CreateChildEntity() Call stream.WriteText(strbody) Call bodyChild.SetContentFromText(stream, "text/HTML;charset=UTF-8", ENC_NONE) Call stream.Close Call stream.Truncate This will run though an array of attachment paths and add them to the email For i = 0 To UBound(Attach) strAttach = Attach(i) If Len(strAttach) > 0 And Len(Dir(strAttach)) > 0 Then Get the attachment file name pos = InStrRev(strAttach, "\") Filename = Right(strAttach, Len(strAttach) - pos) A new child mime entity to hold a file attachment Set bodyChild = body.CreateChildEntity() Set header = bodyChild.CreateHeader("Content-Type") Call header.SetHeaderVal("multipart/mixed") Set header = bodyChild.CreateHeader("Content-Disposition") Call header.SetHeaderVal("attachment; filename=" & Filename) Set header = bodyChild.CreateHeader("Content-ID") Call header.SetHeaderVal(Filename) Set stream = s.CreateStream() If Not stream.Open(strAttach, "binary") Then MsgBox "Open failed" End If If stream.Bytes = 0 Then MsgBox "File has no content" End If Call bodyChild.SetContentFromBytes(stream, "application/octet-stream", ENC_IDENTITY_BINARY) All my attachments are excel this would need changing depensding on your attachments. End If Next Send the email Call message.Send(False) s.ConvertMIME = True Restore conversion End Function

View Code VBA

但是现实情况是这样的

我们需要邮件从公邮发送出去

何谓公邮:整个Team使用的邮箱,如***[email protected] 之类的邮箱

使用过反人类的 Lotus notes 都知道公邮是需要先打开小我私家邮箱才华进去的 

于是当我把以上的VBA 代码增加如下代码,设置从公邮里面发送邮件后