Vba 来自Excel宏的会议邀请-无正文，设置为约会

我正在尝试创建一个vba宏，该宏使用工作表中的变量数据生成会议邀请

我的第一个问题是，它只作为约会打开，而不是作为与列出的被邀请者的会议打开（但是，如果我在约会上单击“邀请与会者”，他们将被预先填充）

我的第二个问题是，我想要的身体信息没有显示出来

下面是代码，有人能帮忙吗

Sub Consolidation_Invite()
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
'Don't forget to copy the function RangetoHTML in the module.
'Working in Excel 2000-2016
    Dim rng As Range
    Dim OutApp As Object
    Dim objMyApptItem As Object
    Dim recipients As Range


    Set rng = Nothing
    On Error Resume Next
    'You can use a fixed range or the visible cells in the selection
    'Selection.SpecialCells(xlCellTypeVisible)
    'Set rng = Sheets("YourSheet").Range("D4:D12").SpecialCells(xlCellTypeVisible)
    Set rng = Sheets("Calendar Invite").Range("A21:B50").SpecialCells(xlCellTypeVisible)
    On Error GoTo 0

    If rng Is Nothing Then
        MsgBox "The selection is not a range or the sheet is protected" & _
               vbNewLine & "please correct and try again.", vbOKOnly
        Exit Sub
    End If

    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With

    Set OutApp = CreateObject("Outlook.Application")
    Set objMyApptItem = OutApp.CreateItem(1)
    Set recipients = Worksheets("Calendar Invite").Range("B11")

    On Error Resume Next
    With objMyApptItem
        .MeetingStatus = olMeeting
        .recipients.Add recipients
        .Location = " Phone Call"
        .Subject = Worksheets("Calendar Invite").Range("B13")
        .Start = Worksheets("Calendar Invite").Range("B15")
        .AllDayEvent = "False"
        .HTMLBody = RangetoHTML(rng)
        .Display   'or use .Send

    End With
    On Error GoTo 0

    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With

    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub


Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
    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

---

这是一个会议请求。无法创建MeetingItem对象，它是在将AppointmentItem对象的MeetingStatus属性设置为olMeeting并将其发送给一个或多个用户时自动创建的。收件人将作为会议项目接收

---

对于第二个问题，AppointItem对象不支持HTMLBody属性；只有Body和RTFBody。

这是一个会议请求。无法创建MeetingItem对象，它是在将AppointmentItem对象的MeetingStatus属性设置为olMeeting并将其发送给一个或多个用户时自动创建的。收件人将作为会议项目接收

---

对于第二个问题，AppointItem对象不支持HTMLBody属性；只有Body和RTFBody。

我找到了答案，因此发布了解决方案，以防其他人希望使用相同的解决方案。基本上，由于你不能使用HTMLBody，你可以在Word中创作。因此，这将复制并粘贴到word编辑器中

默认情况下，我仍然无法让它显示被邀请者。。。但点击“邀请与会者”按钮并不是什么好事

Sub Consolidation_Invite()

Dim olApp As Object
Dim olApt As Object
Dim RCP As Range

Const wdPASTERTF As Long = 1

Set olApp = CreateObject("Outlook.Application")
Set olApt = olApp.CreateItem(1)
Set RCP = Worksheets("Calendar Invite").Range("B11")

With olApt
    .MeetingStatus = olMeeting
    .Start = Worksheets("Calendar Invite").Range("B15")
    .AllDayEvent = "False"
    .recipients.Add RCP
    .Location = "Phone Call (please be at your computer)"
    .Subject = Worksheets("Calendar Invite").Range("B13")
    Sheets("Calendar Invite").Range("A21:B50").Copy
    .Display
    .GetInspector.WordEditor.Windows(1).Selection.PasteAndFormat wdPASTERTF
End With

End Sub

---

我找到了答案，所以发布了解决方案，以防其他人希望使用相同的解决方案。基本上，由于你不能使用HTMLBody，你可以在Word中创作。因此，这将复制并粘贴到word编辑器中

默认情况下，我仍然无法让它显示被邀请者。。。但点击“邀请与会者”按钮并不是什么好事

Sub Consolidation_Invite()

Dim olApp As Object
Dim olApt As Object
Dim RCP As Range

Const wdPASTERTF As Long = 1

Set olApp = CreateObject("Outlook.Application")
Set olApt = olApp.CreateItem(1)
Set RCP = Worksheets("Calendar Invite").Range("B11")

With olApt
    .MeetingStatus = olMeeting
    .Start = Worksheets("Calendar Invite").Range("B15")
    .AllDayEvent = "False"
    .recipients.Add RCP
    .Location = "Phone Call (please be at your computer)"
    .Subject = Worksheets("Calendar Invite").Range("B13")
    Sheets("Calendar Invite").Range("A21:B50").Copy
    .Display
    .GetInspector.WordEditor.Windows(1).Selection.PasteAndFormat wdPASTERTF
End With

End Sub

---

谢谢你，埃里克。我还在学习VBA，所以在我开始尝试解决这个问题之前，有没有一种方法可以从excel中复制一个范围并使用.Body将其粘贴到电子邮件中？谢谢Eric。我还在学习VBA，所以在我开始尝试解决这个问题之前，有没有一种方法可以从excel中复制一个范围并使用.Body将其粘贴到电子邮件中？做得好-这正是我在一个商业插件中使用的方法（hack！）。这真的是唯一的方法，除非你是一个受虐狂，想学习RTF命令！仅供参考，您可以通过使用Microsoft Active Accessibility SDK或Redemption自动单击功能区按钮来显示与会者页面。干得好-这正是我在一个商业插件中必须使用的方法（hack！）。这真的是唯一的方法，除非你是一个受虐狂，想学习RTF命令！仅供参考，您可以通过使用Microsoft Active Accessibility SDK或Redemption自动单击功能区按钮来显示与会者页面。