Outlook 2000 Appointment start time correction

If you ever enter a whole bunch of appointments only to find out you
forgot to change your time zone on your computer, the following will
change all the start times to one hour earlier.

Sub CorrectCalendarStartTimes()
' This code changes the start time of all appointments in a date range
' to one hour earlier unless the body has OK in it.
' allows you to correct appointments with the time zone set
incorrectly
' when the appointments were entered.

Dim oOutApp As Outlook.Application
Dim oNS As Outlook.NameSpace
Dim CalFolder As Outlook.MAPIFolder
Dim CalItems As Outlook.Items
Dim ResItems As Outlook.Items
Dim sFilter As String
Dim iNumRestricted As Integer
Dim itm As Object


Set oOutApp = New Outlook.Application
Set oNS = oOutApp.GetNamespace("MAPI")

' Use the default calendar folder
Set CalFolder = oNS.GetDefaultFolder(olFolderCalendar)

' Get all of the appointments in the folder
Set CalItems = CalFolder.Items

' Sort all of the appointments based on the start time
CalItems.Sort "[Start]"

' Make sure to include all of the recurrences
CalItems.IncludeRecurrences = True

'create the Restrict filter to Limit the date CHANGE TO Yours
sFilter = "[Start] >= '" & Format("11/1/2004 12:00am", _
"ddddd h:nn AMPM") & "'" & " And [End] < '" & _
Format("5/15/2005 12:00am", "ddddd h:nn AMPM") & "'"

' Apply the filter to the collection
Set ResItems = CalItems.Restrict(sFilter)

' This will return 2147843647 if any recurring appointment does not
have an end date
MsgBox ResItems.Count

iNumRestricted = 0

'Loop through the items in the collection. This will not loop
infinitely.
For Each itm In ResItems
iNumRestricted = iNumRestricted + 1
' Doesn't modify anything with the body set to OK
If itm.Body <> "OK" Then
Debug.Print itm.Subject & ": " & itm.Start & " : " & itm.End &
" " & itm.Body
itm.Start = DateAdd("H", -1, itm.Start) ' Adjust to one hour
less
Debug.Print itm.Subject & ": " & itm.Start & " : " & itm.End &
" " & itm.Body
itm.Save
End If
Next

' Display the actual number of appointments in time period.
MsgBox iNumRestricted

Set itm = Nothing
Set ResItems = Nothing
Set CalItems = Nothing
Set CalFolder = Nothing
Set oNS = Nothing
Set oOutApp = Nothing

End Sub