title: Lotus Notes insert html body macro and send from excel
body: <p>I have a macro that sends auto mails from excel via Lotus Notes. The problem is that it doesn't send the body as HTML. It sends as plain text. </p>
  
  <p>This line has the problem:</p>
  
  <pre><code>.inserttext ("some text" &amp; RangetoHTML(rng))
  </code></pre>
  
  <p>The whole code is below.</p>
  
  <pre><code> Sub Send_Row()
  
  Dim OutApp As Object
  Dim OutMail As Object
  Dim cell As Range
  Dim rng As Range
  Dim Ash As Worksheet
  Dim strbody As String
  Dim signature As String
  Dim tekstas As String
  
  Dim noSession As Object
  Dim noDatabase As Object
  Dim noDocument As Object
  Dim noEmbedObject As Object
  Dim noAttachment As Object
  Dim stAttachment As String
  
  answer = MsgBox("Yes - siųsti visiems išskyrus dėl tegų" &amp; vbNewLine &amp; "No - siųsti tik dėl nesuvestų tegų (laiškai bus iškart išsiųsti(" &amp; vbNewLine &amp; "Cancel - nutraukti siuntimą", vbYesNoCancel + vbQuestion, "Siųsti laiškus?")
  If answer = vbYes Then
  
  Exit sub
  
  ElseIf answer = vbNo Then
  tekstas = "&lt;p style='font-size:12pt;font face:""Trebuchet MS""'&gt; Laba diena,&lt;br&gt; &lt;br&gt; Siunčiu mokėjimo kortelių sandorius, kuriems nėra suvesti kliento sutikimo tegai CRD_SUTIK_DATA ir/ar CRD_SUTIK_DUOM. Prašau juos suvesti ir mane informuoti. Ačiū.&lt;br&gt;&lt;br&gt; Geros dienos!"
  
  For Each cell In Ash.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
      If cell.Value Like "?*@?*.?*" _
         And LCase(cell.Offset(0, 23).Value) = "klaida" Then
          On Error Resume Next
          'Change the filter range and filter Field if needed
          'It will filter on Column B now (mail addresses)
          Ash.Range("A28:AJ10000").AutoFilter Field:=2, Criteria1:=cell.Value
          Ash.Range("A28:AJ10000").AutoFilter Field:=25, Criteria1:="klaida"
  
          With Ash.AutoFilter.Range
              On Error Resume Next
              Set rng = .SpecialCells(xlCellTypeVisible)
              On Error GoTo 0
          End With
  
  Set noSession = CreateObject("Notes.NotesSession")
  Set noDatabase = noSession.GETDATABASE("", "")
  If noDatabase.IsOpen = False Then noDatabase.OPENMAIL
  Set noDocument = noDatabase.CreateDocument
  
          On Error Resume Next
  
  noSession.ConvertMIME = False
  
  Dim workspace As Variant
  
  noDocument.PostedDate = Now()
  
  With noDocument
    .Form = "Memo"
    .SendTo = cell.Value
    .Subject = "labas"
    .Body = ""
    .SaveMessageOnSend = True
    .PostedDate = Now()
  End With
  
  Set workspace = CreateObject("Notes.NotesUIWorkspace")
  Set notesUIDoc = workspace.EditDocument(True, noDocument)
  
  With notesUIDoc
      .gotofield "Body"
      .inserttext ("some text" &amp; RangetoHTML(rng))
      .SaveMessageOnSend = True
      '.send
      .Close
  End With
  
      On Error GoTo 0
  
      Ash.AutoFilterMode = False
  
      Columns("B:B").Select
      Selection.Replace What:=cell.Value, Replacement:="", LookAt:=xlPart, _
      SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
      ReplaceFormat:=False
  
      End If
  Next cell
  Else
  GoTo cleanup
  End If
  
  cleanup:
  ActiveSheet.Range("$A$28:$AJ$12000").AutoFilter
  
  Set noEmbedObject = Nothing
  Set noAttachment = Nothing
  Set noDocument = Nothing
  Set noDatabase = Nothing
  Set noSession = Nothing
  End Sub
  
  Function RangetoHTML(rng As Range)
  
  Dim fso As Object
  Dim ts As Object
  Dim TempFile As String
  Dim TempWB As Workbook
  
  TempFile = Environ$("temp") &amp; "/" &amp; Format(Now, "dd-mm-yy h-mm-ss") &amp; ".htm"
  
  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
  
      Columns(1).EntireColumn.Delete
      Columns(32).EntireColumn.Delete
      Columns(33).EntireColumn.Delete
  
      On Error Resume Next
      .DrawingObjects.Visible = True
      .DrawingObjects.Delete
      On Error GoTo 0
  End With
  
  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
  
  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=")
  
  TempWB.Close savechanges:=False
  
  Kill TempFile
  
  Set ts = Nothing
  Set fso = Nothing
  Set TempWB = Nothing
  End Function
  </code></pre>