Excel VBA 创建新的 Outlook 约会导致约会取消答案

【问题标题】：Excel VBA creating a new Outlook appointment results in a cancelled appointmentExcel VBA 创建新的 Outlook 约会导致约会取消
【发布时间】：2023-02-14 03:33:09
【问题描述】：

当我使用 .display 运行以下代码时，Outlook 约会以正确的方式（共享日历、收件人、时间等）创建，我可以发送生成的会议请求，收件人将其作为会议请求接收。但是，如果我将 .display 更改为 .send，一切似乎都正常，但收件人收到会议取消通知（对于不存在的会议！）。

谁能指出我哪里出错了？

Sub CreateMeetings()

Dim olApp As Outlook.Application
Dim olAppItem As Outlook.AppointmentItem
Dim r As Long
Dim oApp As Object
Dim oNameSpace As Namespace
Dim myCalendar As Object
Dim OLNS As Object
Const olAppointmentItem As Long = 1
Dim OLAppointment As Object
Dim MeetingKey As String
Dim datenum As Long
Dim smtprecipient As String
Dim MeetingKeyString As String
Dim emailchk As Long



Set oApp = New Outlook.Application
Set olApp = CreateObject("Outlook.Application")

On Error Resume Next


Set olApp = GetObject("", "Outlook.Application")
On Error GoTo 0
If olApp Is Nothing Then
On Error Resume Next
Set olApp = CreateObject("Outlook.Application")
On Error GoTo 0
If olApp Is Nothing Then
MsgBox "Outlook is not available!"
Exit Sub
End If
End If
'get default user email address
smtprecipient = GetSMTPEmailAddress

'check to see if email address returned is a valid one
emailchk = InStr(1, smtprecipient, "@company_domain.co.uk")
'get a valid email address if the check fails
If emailchk = 0 Then
    smtprecipient = InputBox("Enter your Company Email Address", "Email Address Required")
End If


Set OLNS = olApp.GetNamespace("MAPI")
    OLNS.Logon
    Dim objRec As Outlook.Recipient
    Set objRec = OLNS.CreateRecipient(smtprecipient)
    objRec.Resolve
    Set myCalendar = OLNS.GetSharedDefaultFolder(objRec, olFolderCalendar).Folders("Frontline")
    Set OLAppointment = myCalendar.Items.Add(olAppointmentItem)
    Dim i As Long, Schedsht As Worksheet
    Set Schedsht = Worksheets("Shift Allocation")
    Sheets("Shift Allocation").Select

For i = 6 To Range("A" & Rows.Count).End(xlUp).Row
If Schedsht.Range("T" & i).Value = "" And Schedsht.Range("S" & i).Value = True Then
datenum = Date + (Time * 10000) + i
MeetingKeyString = Schedsht.Range("Z" & i).Value
MeetingKey = "S" & CStr(datenum) & Schedsht.Range("B" & i).Value
    With OLAppointment
            .Subject = "Shift" & " (" & MeetingKey & ")"
            .RequiredAttendees = Schedsht.Range("I" & i).Value & ";" & Schedsht.Range("J" & i).Value _
             & ";" & Schedsht.Range("K" & i).Value
            .Start = Schedsht.Range("D" & i).Value
            .End = Schedsht.Range("E" & i).Value
            .Location = Schedsht.Range("C" & i).Value
            .ReminderMinutesBeforeStart = 720
            .MeetingStatus = olMeeting
            
            .Body = Schedsht.Range("M" & i).Value & vbCrLf & vbCrLf & "Welcome to our new Rota system. For details on how this all works, _
            please go to xxxx."
           .Display
            '.Send
        On Error GoTo 0
    End With

Schedsht.Range("T" & i).Value = True
Schedsht.Range("Y" & i).Value = MeetingKey
Schedsht.Range("AA" & i).Value = MeetingKeyString
Else

End If

Next i
 
MsgBox "All Shifts Processed"
Set olAppItem = Nothing
Set olApp = Nothing
Set oFolder = Nothing

Exit Sub

Set olAppItem = Nothing
Set olApp = Nothing
Set oFolder = Nothing
End Sub

往上看。更改为 .display 可以，.send 不行

【问题讨论】：

标签： excel vba outlook office-automation meeting-request

【解决方案1】：

您不能明确地从共享文件夹发送项目，因为将使用不正确的发件人。当您需要代表其他人发送邮件时，您可以将 SentOnBehalfOfName 属性用于邮件项目，但不能用于约会。

【讨论】：