Question

在Outlook共享日历中，我需要删除所选日期的所有项目，但在将会议状态设置为“已取消”之前。删除效果非常好，但设置状态不是。但是，在调试时，“.MeetingStatus = olMeetingCanceled”的效果非常好（请使用“If isDelete Then”）。任何建议都非常感谢。非常感谢

        Function DeleteAppointments(ByVal attendeeName As String, ByVal startDateTime As String, ByVal endDateTime As String, ByVal appSubjectFilter As String, ByVal folderCalendar As String, ByVal subFolderCalendar As String) As String

 DeleteAppointments = ""
 Dim oApp As Outlook.Application
 Dim oNameSpace As Outlook.NameSpace
 Dim oFolder As Outlook.MAPIFolder
 Dim oApptItem As Outlook.AppointmentItem
 Dim sErrorMessage As String 

' check if Outlook is running
On Error Resume Next
Set oApp = GetObject("Outlook.Application")
If Err <> 0 Then
    'if not running, start it
    Set oApp = CreateObject("Outlook.Application")
End If

'get shared Outlook Folder reference
Set oApp = Outlook.Application
On Error GoTo Err_Handler
Set oNameSpace = oApp.GetNamespace("MAPI")
Set oFolder = oNameSpace.GetDefaultFolder(olFolderCalendar)

Set oFolder = oNameSpace.folders(folderCalendar).folders(subFolderCalendar)
Set oItems = oFolder.Items
oItems.IncludeRecurrences = False
oItems.Sort "[Start]"

'Restrict the Items collection for a day
Dim sFilter As String
sFilter = "[Start]>='" & startDateTime & "' AND [Start]<='" & endDateTime & "'"
Set oItemsInDateRange = oItems.Restrict(sFilter)
oItemsInDateRange.Sort "[Start]"

Dim isDelete As Boolean
isDelete = False

Dim i As Integer
i = 1
While i <= oItemsInDateRange.Count

    DoEvents

    If InStr(oItemsInDateRange(i).Subject, appSubjectFilter) > 0 Then
        If InStr(oItemsInDateRange(i).Subject, attendeeName) > 0 Then
            isDelete = True
        End If
    End If
    If isDelete Then
        'THIS BIT WORKS WHEN DUBUGGING ONLY :-(
       oItemsInDateRange(i).MeetingStatus = olMeetingCanceled
       oItemsInDateRange(i).Save
       oItemsInDateRange(i).Send
       'Delete works ok
        oItemsInDateRange(i).Delete
        i = i - 1
    End If
    isDelete = False

    i = i + 1
    Set oItems = oFolder.Items
    oItems.IncludeRecurrences = False
    Set oItemsInDateRange = oItems.Restrict(sFilter)
    oItemsInDateRange.Sort "[Start]"
Wend

Set oApptItem = Nothing
Set oItemsInDateRange = Nothing
Set oItems = Nothing
Set oFolder = Nothing
Set oNameSpace = Nothing
Set oApp = Nothing

Exit Function

Err_Handler:

    DeleteAppointments = "Error while deleting. " & Err.Number & " " &      Err.Description

End Function

Answer 1

仅在调试是一种常见的抱怨时才有效。

尝试在调试器中进行减慢过程。

If isDelete Then
    oItemsInDateRange(i).MeetingStatus = olMeetingCanceled
    oItemsInDateRange(i).Save

    oItemsInDateRange(i).Display True ' Send manually

    oItemsInDateRange(i).Delete
    i = i - 1
End If

跑得更慢：

https://msdn.microsoft.com/en-us/library/office/ff861853.aspx

Router.current().params.query_param1

Answer 2

感谢＆＃39; niton＆＃39;下面是代码，如果你想在outlooks中删除任何日历中的约会/会议（只需传递正确的文件夹名称）。

在我的情况下，我已经共享了通用邮件帐户，并在我的Outlook中添加了日历，其中＆＃34;文件夹列表＆＃34;结构如下：

->Mailbox My name
   -> Inbox
   ->etc
->Staff Diary
   -> Inbox
   -> ...
   -> Calendar
   -> other subfolders for shared account

然后我运行如下函数：

      Dim smsg As String
      smsg = DeleteAppointments("John Smith", _
         Format(currentDate, "dd/mm/yyyy") & " 00:00", _
         Format(currentDate, "dd/mm/yyyy") & " 23:59", _
         "red room invite", "Staff Diary", "Calendar")
      If (smsg <> "") Then
         MsgBox (smsg)
         GoTo endsub
      End If

功能：

Function DeleteAppointments(ByVal attendeeName As String, ByVal startDateTime As String, ByVal endDateTime As String, ByVal appSubjectFilter As String, ByVal folderCalendar As String, ByVal subFolderCalendar As String) As String

 DeleteAppointments = ""
 Dim oApp As Outlook.Application
 Dim oNameSpace As Outlook.NameSpace
 Dim oFolder As Outlook.MAPIFolder
 Dim oApptItem As Outlook.AppointmentItem
 Dim sErrorMessage As String

On Error Resume Next
' check if Outlook is running
Set oApp = GetObject("Outlook.Application")
If Err <> 0 Then
    'if not running, start it
    Set oApp = CreateObject("Outlook.Application")
End If
Set oApp = Outlook.Application

'On Error GoTo Err_Handler

Set oNameSpace = oApp.GetNamespace("MAPI")
Set oFolder = oNameSpace.GetDefaultFolder(olFolderCalendar)    '
'Gets the parent of your Inbox which gives the Users email
Set oFolder = oNameSpace.folders(folderCalendar).folders(subFolderCalendar)
Set oItems = oFolder.Items
oItems.IncludeRecurrences = False
oItems.Sort "[Start]"
'Restrict the Items collection for a day
Dim sFilter As String
sFilter = "[Start]>='" & startDateTime & "' AND [Start]<='" & endDateTime & "'"
Set oItemsInDateRange = oItems.Restrict(sFilter)
oItemsInDateRange.Sort "[Start]"

Dim isDelete As Boolean
isDelete = False

Dim i As Integer
i = 1
While i <= oItemsInDateRange.Count

    DoEvents

    If InStr(oItemsInDateRange(i).Subject, appSubjectFilter) > 0 Then
        If InStr(oItemsInDateRange(i).Subject, attendeeName) > 0 Then
            isDelete = True
        End If
    End If
    If isDelete Then
        'below line is essential to ensure that the status is changed
        oItemsInDateRange(i).Display
        oItemsInDateRange(i).Subject = "Cancelled"
        oItemsInDateRange(i).MeetingStatus = olMeetingCanceled
        oItemsInDateRange(i).MeetingStatus = 5
        DoEvents
        oItemsInDateRange(i).Save
        DoEvents
        oItemsInDateRange(i).Send
        DoEvents
        oItemsInDateRange(i).Delete
        i = i - 1
    End If
    isDelete = False

    i = i + 1
    Set oItems = oFolder.Items
    oItems.IncludeRecurrences = False
    Set oItemsInDateRange = oItems.Restrict(sFilter)
    oItemsInDateRange.Sort "[Start]"
Wend

Set oApptItem = Nothing
Set oItemsInDateRange = Nothing
Set oItems = Nothing
Set oFolder = Nothing
Set oNameSpace = Nothing
Set oApp = Nothing

Exit Function

Err_Handler:

DeleteAppointments = "Error while deleting. " & Err.Number & " " & Err.Description

End Function

然后使用以下脚本删除与会者帐户中已取消的约会。此脚本应作为规则运行，其中主题具有＆＃34;已取消＆＃34;文本：

Sub AutoDeleteCancelledMeetings(oRequest As MeetingItem)

  Dim oAppt As AppointmentItem
  Set oAppt = oRequest.GetAssociatedAppointment(False)

  'If oAppt.Subject <> "Cancelled" Then
  '    Exit Sub
  'End If

  oAppt.Delete

End Sub

希望这会对某人有所帮助。

VBA Outlook'olMeetingStatus = olMeetingCanceled仅适用于调试（Win7，Outlook 2010）

2 个答案: