使用VBA通过IBM Notes发送HTML电子邮件？
我正在使用以下代码通过Excel和IBM Notes使用vba发送HTML电子邮件。
这是我的代码：
Sub SendEmail() Application.DisplayAlerts = False Application.ScreenUpdating = False Application.CutCopyMode = False 'Define Variables Dim Ref As String Dim TrueRef As String Dim Attachment As String Dim WB3 As Workbook Dim WB4 As Workbook Dim Rng As Range Dim db As Object Dim doc As Object Dim body As Object Dim header As Object Dim stream As Object Dim session As Object Dim i As Long Dim j As Long Dim j2 As Long Dim server, mailfile, user, usersig As String Dim LastRow As Long, LastRow2 As Long, WS As Worksheet LastRow = Worksheets(1).Range("F" & Rows.Count).End(xlUp).Row 'Finds the last used row 'Define Depot Ref = Range("G" & (ActiveCell.Row)).Value If Ref = "WED" Then TrueRef = "WED" Else If Ref = "WSM" Then TrueRef = "WES" Else If Ref = "NAY" Then TrueRef = "NAY" Else If Ref = "ENF" Then TrueRef = "ENF" Else If Ref = "LUT" Then TrueRef = "MAG" Else If Ref = "NFL" Then TrueRef = "NOR" Else If Ref = "RUN" Then TrueRef = "RUN" Else If Ref = "SOU" Then TrueRef = "SOU" Else If Ref = "SOU" Then TrueRef = "SOU" Else If Ref = "BRI" Then TrueRef = "BRI" Else If Ref = "LIV" Then TrueRef = "LIV" Else If Ref = "BEL" Then TrueRef = "BEL" End If End If End If End If End If End If End If End If End If End If End If End If 'Start a session of Lotus Notes Set session = CreateObject("Notes.NotesSession") 'This line prompts for password of current ID noted in Notes.INI Set db = session.CurrentDatabase Set stream = session.CreateStream ' Turn off auto conversion to rtf session.ConvertMIME = False 'Email Code 'Create email to be sent Set doc = db.CreateDocument doc.Form = "Memo" Set body = doc.CreateMIMEEntity Set header = body.CreateHeader("Food Specials Delivery Tracker: The Status of Your Issue Has Changed (" & Range("O" & ActiveCell.Row).Value & ")") Call header.SetHeaderVal("HTML message") 'Set From Call doc.ReplaceItemValue("Principal", "Food Specials <mailto:Food.Specials@Lidl.co.uk>") Call doc.ReplaceItemValue("ReplyTo", "Food.Specials@Lidl.co.uk") Call doc.ReplaceItemValue("DisplaySent", "Food.Specials@Lidl.co.uk") Call doc.ReplaceItemValue("Subject", "Food Specials Delivery Tracker: The Status of Your Issue Has Changed (" & Range("O" & ActiveCell.Row).Value & ")") 'To Set header = body.CreateHeader("To") 'Call header.SetHeaderVal("Supplychain-" & TrueRef & "@lidl.co.uk") Call header.SetHeaderVal("Apollonia.Repse@lidl.co.uk") 'Email Body Call stream.WriteText("<HTML>") Call stream.WriteText("<font size=""3"" color=""black"" face=""Arial"">") If Hour(Now) > 12 Then Call stream.WriteText("<p>Good afternoon,</p>") Else Call stream.WriteText("<p>Good morning,</p>") End If Call stream.WriteText("<p>Reference: " & Format(CDate(Range("A" & ActiveCell.Row).Value), "DDMMYY") & " - " & Range("C" & ActiveCell.Row).Value & " - " & Range("D" & ActiveCell.Row).Value & "</p>") If ThisWorkbook.Sheets(1).Range("O" & ActiveCell.Row).Value = "Issue Complete" Then Call stream.WriteText("<p>Your recent issue has been marked as complete.</p>") Else Call stream.WriteText("<p>The status of your recent issue has changed.</p>") End If 'Insert Range ThisWorkbook.Sheets(1).Range("A" & ActiveCell.Row & ":L" & ActiveCell.Row & ", O" & ActiveCell.Row).SpecialCells(xlCellTypeVisible).Select Set Rng = Selection Call stream.WriteText(RangetoHTML(Rng)) Cells(1, 1).Select Call stream.WriteText("<BR><BR><p><a href=""G:\WH DISPO\(3) PROMOTIONS\(18) Food Specials Delivery Tracking\Food Specials Delivery Tracker.xlsm"">Click here to view your issue on the Delivery Tracker now.</a></p></br>") 'Signature Call stream.WriteText("<BR><p>Kind regards / Mit freundlichen Grüßen,</p></br>") Call stream.WriteText("<p><b>Lidl UK Food Specials Team</b></p>") Call stream.WriteText("<table border=""0"">") Call stream.WriteText("<tr>") Call stream.WriteText("<td><img src=""http://www.lidl.co.uk/statics/lidl-uk/ds_img/layout/top_logo2016.jpg"" alt=""Mountain View""></td>") Call stream.WriteText("<td><img src=""http://www.lidl.co.uk/statics/lidl-uk/ds_img/assets_x_x/BOQLOP_NEW%281%29.jpg"" alt=""Mountain View""></td>") Call stream.WriteText("</tr>") Call stream.WriteText("</table>") Call stream.WriteText("</font>") Call stream.WriteText("</body>") Call stream.WriteText("</html>") Call body.SetContentFromText(stream, "text/HTML;charset=UTF-8", ENC_IDENTITY_7BIT) doc.Save True, False Call doc.PutInFolder("TEST") Call doc.Send(False) session.ConvertMIME = True ' Restore conversion - very important 'Clean Up the Object variables - Recover memory Set db = Nothing Set session = Nothing Set stream = Nothing Set doc = Nothing Set body = Nothing Set header = Nothing 'WB3.Close savechanges:=False Application.CutCopyMode = False 'Email Code Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub Function RangetoHTML(Rng As Range) ' Changed by Ron de Bruin 28-Oct-2006 ' Working in Office 2000-2010 Dim fso As Object Dim ts As Object Dim TempFile As String Dim TempWB As Workbook TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm" 'Copy the range and create a new workbook to past the data in Rng.Copy Set TempWB = Workbooks.Add(1) With TempWB.Sheets(1) .Cells(1).PasteSpecial Paste:=8 .Cells(1).PasteSpecial xlPasteValues, , False, False .Cells(1).PasteSpecial xlPasteFormats, , False, False .Cells(1).Select Application.CutCopyMode = False On Error Resume Next .DrawingObjects.Visible = True .DrawingObjects.Delete On Error GoTo 0 End With 'Publish the sheet to a htm file With TempWB.PublishObjects.Add( _ SourceType:=xlSourceRange, _ Filename:=TempFile, _ Sheet:=TempWB.Sheets(1).Name, _ Source:=TempWB.Sheets(1).UsedRange.Address, _ HtmlType:=xlHtmlStatic) .Publish (True) End With 'Read all data from the htm file into RangetoHTML Set fso = CreateObject("Scripting.FileSystemObject") Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2) RangetoHTML = ts.ReadAll ts.Close RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _ "align=left x:publishsource=") 'Close TempWB TempWB.Close SaveChanges:=False 'Delete the htm file we used in this function Kill TempFile Set ts = Nothing Set fso = Nothing Set TempWB = Nothing End Function 如果我发送电子邮件给自己，HTML内容显示。
但是，如果我发送给任何人 – 发生这种情况：
请有人告诉我我要去哪里错了吗？
这个标题是错误的第一件事：
Set header = body.CreateHeader("Food Specials Delivery Tracker: The Status of Your Issue Has Changed (" & Range("O" & ActiveCell.Row).Value & ")")
标题字段名称不能包含空格。 当其他电子邮件系统看到这一点时，他们不会将该行视为标题。 他们开始把它作为一个纯文本的消息体来处理它，并把它跟在它后面。
我没有继续寻找错误，所以可能不是唯一的错误。
这是几个月来第二次，我看到了这样一个真正复杂而又笨拙的if语句。 这是在某个地区或某些特定的培训中教授的东西吗？
我会重写它，使其更容易阅读和维护。 这可以通过几种方式来完成。
留下if-statments：
TrueRef = Ref If Ref = "WSM" Then TrueRef = "WES" ElseIf Ref = "LUT" Then TrueRef = "MAG" ElseIf Ref = "NFL" Then TrueRef = "NOR" End If
或者像这样：
If Ref = "WSM" Then TrueRef = "WES" ElseIf Ref = "LUT" Then TrueRef = "MAG" ElseIf Ref = "NFL" Then TrueRef = "NOR" Else TrueRef = Ref End If
您也可以使用Select Case语句：
Select Case Ref Case "WSM" TrueRef = "WES" Case "LUT" TrueRef = "MAG" Case "NFL" TrueRef = "NOR" Case Else TrueRef = Ref End Select
比较你的原始代码：
If Ref = "WED" Then TrueRef = "WED" Else If Ref = "WSM" Then TrueRef = "WES" Else If Ref = "NAY" Then TrueRef = "NAY" Else If Ref = "ENF" Then TrueRef = "ENF" Else If Ref = "LUT" Then TrueRef = "MAG" Else If Ref = "NFL" Then TrueRef = "NOR" Else If Ref = "RUN" Then TrueRef = "RUN" Else If Ref = "SOU" Then TrueRef = "SOU" Else If Ref = "SOU" Then TrueRef = "SOU" Else If Ref = "BRI" Then TrueRef = "BRI" Else If Ref = "LIV" Then TrueRef = "LIV" Else If Ref = "BEL" Then TrueRef = "BEL" End If End If End If End If End If End If End If End If End If End If End If End If