Question

我有一个通过Lotus Notes从excel发送自动邮件的宏。问题是它不会将正文作为HTML发送。它以纯文本形式发送。

这一行存在问题：

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

整个代码如下。

 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

按设计工作。 InsertText只是将纯文本插入字段。您需要使用后端类NotesDocument和NotesRichtextItem，或者您可以使用NotesMIMEEntry类

Lotus Notes插入html body宏并从excel发送

1 个答案: