Outlook appointment via excel VBA issue-CodePudding

I am struggling to do the following. The code below all works fine, but the range being copied and pasted comes above the body of the e-mail whereas I need it below. Any advise is appreciated.

Sub Email()
Dim OutApp As Outlook.Application
Dim OutMeet AS Outlook.Appointment
Dim x as Integer
Set OutApp = Outlook.Application
Set OutMeet = OutApp.CreateItem(olAppointmentItem)

Const wdPASTERTF as Long = 1

RowCount = Range("").Value

With OutMeet
For x = 1 To Range("")

If Cells (x, 1) = "Yes" Then
.Recipients.Add Celss (x,2)
Else
End If

Next x

With OutMeet
.Body = "Hi"

Range(Cells(3,12), Cells(RowCount  2, 24)).Select
Selection.Copy
.Display
.GetInspector.WordEditor.Windows(1).Selection.PasteAndFormat wdPASTERTF

 End With
 End With
 End Sub

CodePudding user response：

If I'm adding ranges and items after the body, I append the new items onto the old, so i can control the order, using HTMLBody as opposed to just Body:

.HTMLBody = _
    "<HTML><body>All;<br><br>" & _
    "Text " & singleCellValue & ".<br><br></body></HTML>"
.HTMLBody = .HTMLBody & CopyRangeToHTML(rangeOfCells)

Some notes:

A single value taken from a range can be included in the text wherever, e.g., singleCellValue
The double HTML breaks are doubled to 1) get you to the next line, and 2) add another line... I don't tend to have spacing indentations, so keep that in mind if you do
The use of a rangeOfCells is performed via a function, slightly modified from an old Rob de Bruin function to allow copying of conditional formatting:

Private Function CopyRangeToHTML(ByVal n As Range)
    Dim fso As Object, ts As Object, temp As String
    Dim wbs As Workbook: Set wbs = n.Worksheet.Parent
    temp = Environ$("temp") & "/" & Format(Now, "yyyyMMddHHmmss") & ".htm"
    With wbs.PublishObjects.Add(SourceType:=xlSourceRange, Filename:=temp, Sheet:=n.Worksheet.Name, Source:=n.Address, HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(temp).OpenAsTextStream(1, -2)
    CopyRangeToHTML = ts.ReadAll
    ts.Close
    Kill temp
    Set ts = Nothing
    Set fso = Nothing
    Set wbs = Nothing
End Function

CodePudding user response：

Modify CreateAppointment procedure by setting your range and the recipients. Read the comments for better understanding. Your range will be copied to an htm temporary file with RangetoHTML.

In order to create an appointment in HTML format, an temporary email is created in this format in background and then it's content is copied to the appointment.

Public Sub CreateAppointment()
    Dim olApp As Object     ' Outlook application
    Dim olApt As Object     ' Outlook Appointment Item
    Dim olMail As Object    ' Outloot Mail Item
    Dim greetings As String
    
    Set olApp = CreateObject("Outlook.Application")
    Set olMail = olApp.CreateItem(olMailItem)
    Set olApt = olApp.CreateItem(olAppointmentItem)
    
    ' Define your range HERE
    Dim rangeOfCells As Range: Set rangeOfCells = ActiveSheet.ListObjects(1).Range
    
    ' Greetings
    greetings = "Hi," & vbCrLf
    
    With olApt
        .Display
        .Start = Date & " 09:10"
        .Duration = 90
        .Subject = "Report XXX"
        .Location = "Office - XX"
        
        ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        ' Put the HTML into the mail item, then copy and paste to appt
        ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        olMail.BodyFormat = olFormatHTML
        ' Copy rante to mail body
        olMail.HTMLBody = greetings & RangetoHTML(rangeOfCells)
        ' Copy from mail
        olMail.GetInspector().WordEditor.Range.FormattedText.Copy
        ' Paste mail in Appointment
        olApt.GetInspector().WordEditor.Range.FormattedText.Paste
        ' Close mail without saving
        olMail.Close False
        
        ' Uncomment line bellow to save appointment
        '.Save
    End With
    
    Set olMail = Nothing
    Set olApt = Nothing
    Set olApp = Nothing
End Sub

Function RangetoHTML(Rng As Range)
    ' Ron de Bruin: https://www.rondebruin.nl/win/s1/outlook/bmail2.htm
    
    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
        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