vba Excel 创建 Outlook 会议请求，无法发送

Excel create outlook meeting request, not able to send

提问by user1056087

I am working on some code which creates an Outlook Meeting request, and I'd like for it to send to a list of invitees. I'm able to create the Meeting Request, but I am unable to send it. I can see the Meeting Request in my Calendar. How can I get it to send?

我正在处理一些创建 Outlook 会议请求的代码，我希望将其发送给受邀者列表。我可以创建会议请求，但无法发送。我可以在我的日历中看到会议请求。我怎样才能让它发送？

Here's my code:

这是我的代码：

Sub AddAppointments()
' Create the Outlook session
Set myOutlook = CreateObject("Outlook.Application")

' Start at row 2
r = 2

Do Until Trim(Cells(r, 1).Value) = ""
    ' Create the AppointmentItem
    Set myApt = myOutlook.CreateItem(1)
    ' Set the appointment properties
    myApt.Subject = Cells(r, 1).Value
    myApt.Location = Cells(r, 2).Value
    myApt.Start = Cells(r, 3).Value
    myApt.Duration = Cells(r, 4).Value
    myApt.Recipients.Add Cells(r, 8).Value
    myApt.MeetingStatus = olMeeting
    myApt.ReminderMinutesBeforeStart = 88
    myApt.Recipients.ResolveAll
    myApt.AllDayEvent = AllDay


    ' If Busy Status is not specified, default to 2 (Busy)
    If Trim(Cells(r, 5).Value) = "" Then
        myApt.BusyStatus = 2

    Else
        myApt.BusyStatus = Cells(r, 5).Value

    End If
    If Cells(r, 6).Value > 0 Then
        myApt.ReminderSet = True
        myApt.ReminderMinutesBeforeStart = Cells(r, 6).Value
    Else
        myApt.ReminderSet = False
    End If
    myApt.Body = Cells(r, 7).Value
    myApt.Save
    r = r + 1
    myApt.Send
Loop
End Sub

回答by JimmyPena

Without a sample row of values, it's hard to debug this code. So we are only going on your word that it is valid. But I did fix up the code a bit.

如果没有示例值行，则很难调试此代码。所以我们只是按照你的话来说它是有效的。但我确实修复了一些代码。

• You have ReminderMinutesBeforeStarttwice in your code. I removed the first one because it looks like it is dependent upon row data.
• You call the ResolveAllmethod, but don't check to see if your recipients resolved. If they are email addresses, I wouldn't bother.
• There is a mix of early and late bound references. For example, you use 1 instead of olAppointmentItem, but later use olMeeting instead of 1.
• The AllDayEventProperty takes a boolean value, but as you haven't declared any variables we have no way to tell what AllDaymeans. I converted this to read from column I. Also note that if you set AllDayEvent to True, you would not need to set Duration.

• 您的代码中有两次ReminderMinutesBeforeStart。我删除了第一个，因为它看起来依赖于行数据。
• 您调用ResolveAll方法，但不检查您的收件人是否已解决。如果他们是电子邮件地址，我不会打扰。
• 有早期和晚期绑定引用的混合。例如，您使用 1 而不是 olAppointmentItem，但后来使用 olMeeting 而不是 1。
• 该AllDayEvent属性需要一个布尔值，但你有没有声明的变量，我们没有办法告诉什么阿迪手段。我将其转换为从第一列读取。另外请注意，如果将 AllDayEvent 设置为 True，则不需要设置持续时间。

Assuming valid input values, this code worked for me:

假设输入值有效，此代码对我有用：

Option Explicit

Sub AddAppointments()

  Dim myoutlook As Object ' Outlook.Application
  Dim r As Long
  Dim myapt As Object ' Outlook.AppointmentItem

  ' late bound constants
  Const olAppointmentItem = 1
  Const olBusy = 2
  Const olMeeting = 1

  ' Create the Outlook session
  Set myoutlook = CreateObject("Outlook.Application")

  ' Start at row 2
  r = 2

  Do Until Trim$(Cells(r, 1).value) = ""
    ' Create the AppointmentItem
    Set myapt = myoutlook.CreateItem(olAppointmentItem)
    ' Set the appointment properties
    With myapt
      .Subject = Cells(r, 1).value
      .Location = Cells(r, 2).value
      .Start = Cells(r, 3).value
      .Duration = Cells(r, 4).value
      .Recipients.Add Cells(r, 8).value
      .MeetingStatus = olMeeting
      ' not necessary if recipients are email addresses
      ' myapt.Recipients.ResolveAll
      .AllDayEvent = Cells(r, 9).value

      ' If Busy Status is not specified, default to 2 (Busy)
      If Len(Trim$(Cells(r, 5).value)) = 0 Then
        .BusyStatus = olBusy
      Else
        .BusyStatus = Cells(r, 5).value
      End If

      If Cells(r, 6).value > 0 Then
        .ReminderSet = True
        .ReminderMinutesBeforeStart = Cells(r, 6).value
      Else
        .ReminderSet = False
      End If

      .Body = Cells(r, 7).value
      .Save
      r = r + 1
      .Send
    End With
  Loop
End Sub

Sample input values in cells (incl. header row):

单元格中的示例输入值（包括标题行）：

• A2: My Meeting
• B2: My Desk
• C2: 11/25/2011 13:30:00 PM
• D2: 30
• E2: 2
• F2: 30
• G2: Let's have a meeting!
• H2: -email address-
• I2: FALSE

• A2：我的会议
• B2：我的办公桌
• C2：11/25/2011 13:30:00 PM
• D2：30
• E2：2
• F2：30
• G2：开个会吧！
• H2：-电子邮件地址-
• I2：错误

回答by user2416661

It works for me!

这个对我有用！

Please keep in mind to have multiple lines like

请记住有多行，如

.Recipients.Add Cells(r, 8).value

to add more recipients. Because writing several addresses in one cell separeted by ";" leads to an error when sendig the appointment!

添加更多收件人。因为在一个单元格中写入多个地址，以“;”分隔 发送约会时导致错误！

or use

或使用

.Recipients.ResolveAll