VBA Outlook 'olMeetingStatus=olMeetingCanceled works on debug only (Win7, Outlook 2010)

问题

In Outlook shared calendar I need to delete all items for a selected date but before set the meeting status to Cancelled. Deletion works perfectly well, but setting the status not. However when debugging the ".MeetingStatus = olMeetingCanceled" works perfectly well (pls se line with 'If isDelete Then'). Any advise is highly appreciated. Thanks a lot

        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

回答1:

Works only while debugging is a common complaint.

Try slowing the process as is being done in the debugger.

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

    oItemsInDateRange(i).Display

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

To run even slower:

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

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

    oItemsInDateRange(i).Display True ' Send manually

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

回答2:

thanks to 'niton' below here is the code if you want to delete Appointments/Meetings in outlooks any calendar (just pass the correct folder names).

In my case I have shared generic mail account with calendar added to my outlook where "Folder List" structure is as follows:

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

then I run the function as follows:

      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:

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

Then use below script to delete cancelled appointments in Attendees accounts. This script should be run as a rule where subject has "Cancelled" text:

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

Hope this will help someone.

来源：https://stackoverflow.com/questions/35157284/vba-outlook-olmeetingstatus-olmeetingcanceled-works-on-debug-only-win7-outloo

标签

vba

debugging

outlook