Question

我正在尝试创建一个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

Answer 1

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

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

Answer 2

我明白了，所以发布解决方案以防其他人希望使用相同的解决方案。基本上，因为您不能使用HTMLBody，您可以在Word中进行撰写。因此，这将复制并粘贴到单词编辑器中。

我仍然无法默认显示被邀请者...但是点击＆＃34;邀请与会者＆＃34;按钮不是这么一点。

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

从Excel宏会议邀请 - 没有正文，设置为约会

2 个答案: