Lotus Notes HTML-Body-Makro einfügen und senden von Excel

Question

Ich habe ein Makro, das automatische Mails von Excel über Lotus Notes sendet. Das Problem ist, dass es den Körper nicht als HTML sendet. Es wird als einfacher Text gesendet.

Diese Linie hat das Problem:

.inserttext ("some text" & RangetoHTML(rng)) 

Der gesamte Code ist unten.

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ų" & vbNewLine & "No - siųsti tik dėl nesuvestų tegų (laiškai bus iškart išsiųsti(" & vbNewLine & "Cancel - nutraukti siuntimą", vbYesNoCancel + vbQuestion, "Siųsti laiškus?") 
If answer = vbYes Then 

Exit sub 

ElseIf answer = vbNo Then 
tekstas = "<p style='font-size:12pt;font face:""Trebuchet MS""'> Laba diena,<br> <br> 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ū.<br><br> 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" & 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") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".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 

Answer 1

Funktioniert wie geplant. InsertText fügt nur einfachen Text in das Feld ein. Sie müssten die Back-End-Klassen NotesDocument und NotesRichtextItem verwenden oder Sie könnten die NotesMIMEEntry-Klasse