2012-05-22 57 views
1

我試圖從下面的代碼中從Access VBA中刪除Outlook日曆中將來的約會。代碼工作正常,但這些約會已使用房間(資源)設置,並且刪除我的日曆中的約會不會在資源日曆中將其刪除。我該如何解決這個問題?刪除Outlook日曆約會不會釋放空間

Sub NoFuture() 
    'delete any future appointment 
    Dim olApp As Outlook.Application 
    Dim olNs As Outlook.NameSpace 
    Dim olRecItems 
    Dim olFilterRecItems 
    Dim olItem As Outlook.AppointmentItem, strFilter As String 

    Set olApp = CreateObject("Outlook.Application") 
    Set olNs = olApp.GetNamespace("MAPI") 
    Set olRecItems = olNs.GetDefaultFolder(olFolderCalendar) 

    strFilter = "[Start] > '" & Format(Date + 1, "mm/dd/yyyy") & "'" 
    Set olFilterRecItems = olRecItems.Items.Restrict(strFilter) 

    For Each olItem In olFilterRecItems 
     olItem.Delete 
    Next olItem 
    Set olRecItems = Nothing 
    Set olNs = Nothing 
    Set olApp = Nothing 
End Sub 

回答

1

黛安Poremsky has written a macro通過去並刪除取消從資源壓延約會:

' A subroutine to remove cancelled appointments. 
Sub RemoveCanceledAppointments() 

'Form variables. 
Dim OutLookResourceCalendar As Outlook.MAPIFolder, OutLookAppointmentItem As Outlook.AppointmentItem, IntegerCounter As Integer 

'This sets the path to the resource calender. 
Set OutLookResourceCalendar = OpenMAPIFolder("\MailboxName\Calendar") 
For IntegerCounter = OutLookResourceCalendar.Items.Count To 1 Step -1 

Set OutLookAppointmentItem = OutLookResourceCalendar.Items(IntegerCounter) 

    If Left(OutLookAppointmentItem.Subject, 9) = "Canceled:" Then 

     OutLookAppointmentItem.Delete 

    End If 

Next 

Set OutLookAppointmentItem = Nothing 

Set OutLookResourceCalendar = Nothing 

End Sub 

' A function for the folder path. 
Function OpenMAPIFolder(FolderPathVar) 

Dim SelectedApplication, FolderNameSpace, SelectedFolder, FolderDirectoryVar, i 

Set SelectedFolder = Nothing 

Set SelectedApplication = CreateObject("Outlook.Application") 
If Left(FolderPathVar, Len("\")) = "\" Then 

    FolderPathVar = Mid(FolderPathVar, Len("\") + 1) 

Else 

    Set SelectedFolder = SelectedApplication.ActiveExplorer.CurrentFolder 

End If 

While FolderPathVar <> "" 

' Backslash var. 
i = InStr(FolderPathVar, "\") 

     'If a Backslash is present, acquire the directory path and the folder path...[i]. 
     If i Then 

      FolderDirectoryVar = Left(FolderPathVar, i - 1) 

      FolderPathVar = Mid(FolderPathVar, i + Len("\")) 

     Else 

      '[i] ...or set the path to nothing. 
      FolderDirectoryVar = FolderPathVar 

      FolderPathVar = "" 

     End If 

     ' Retrieves the folder name space from the Outlook namespace, unless a folder exists... [ii]. 
     If IsNothing(SelectedFolder) Then 

      Set FolderNameSpace = SelectedApplication.GetNamespace("MAPI") 

      Set SelectedFolder = FolderNameSpace.Folders(FolderDirectoryVar) 

     Else 

     ' [ii] in which case the the existing folder namespace is used. 
      Set SelectedFolder = SelectedFolder.Folders(FolderDirectoryVar) 

     End If 

    Wend 

Set OpenMAPIFolder = SelectedFolder 

End Function 


' A function to check too see if there is no set namespace for the folder path. 
Function IsNothing(Obj) 

If TypeName(Obj) = "Nothing" Then 

    IsNothing = True 

Else 

    IsNothing = False 

End If 

End Function 

讓我知道,如果從資源壓延刪除取消預約 -

〜約爾