In the comments for Extract Calendar data from Outlook into Excel, Keith asks if he can convert multiple-day appointments into single all-day ones. These are all-day appointments that span multiple days, and he needs them to be single day appointments for viewing on the iPhone. Here's how to do it.
The following procedure will convert any multi-day appointments in a given date range to single, all-day events instead. It works by making a copy of any multi-day appointment and creating individual all-day appointments instead.
Sub ChangeMultiDayToSingleDay(startDate As Date, endDate As Date)
Dim allCalendarItems As Outlook.Items
Dim calendarItems As Outlook.Items
Dim appt As Outlook.AppointmentItem
Dim StringToCheck As String
Dim numberOfDays As Long
Dim newAppt As Outlook.AppointmentItem
Set allCalendarItems = GetItems(GetNS(GetOutlookApp), olFolderCalendar)
' get all appts that start after the start date and end before the end date
StringToCheck = "[Start] >= " & Quote(startDate & " 12:00 AM") & _
" AND [End] <= " & Quote(endDate & " 11:59 PM")
Set calendarItems = allCalendarItems.Restrict(StringToCheck)
For Each appt In calendarItems
numberOfDays = appt.End - appt.Start
If numberOfDays > 1 Then
' create a new appt for each day
Do While numberOfDays > 0
Set newAppt = appt.Copy
With newAppt
.Start = DateValue(appt.Start) + numberOfDays - 1
.End = DateValue(appt.Start) + numberOfDays
.AllDayEvent = True
.Save
End With
numberOfDays = numberOfDays - 1
Loop
appt.Delete
End If
Next appt
End Sub
Function GetOutlookApp() As Outlook.Application
' returns native Outlook.Application object
Set GetOutlookApp = Outlook.Application
End Function
Function GetNS(ByRef app As Outlook.Application) As Outlook.NameSpace
' returns native NameSpace Object
Set GetNS = app.GetNamespace("MAPI")
End Function
Function GetItems(olNS As Outlook.NameSpace, _
folder As OlDefaultFolders) As Outlook.Items
' returns the Items Collection for a given default
' folder and Namespace
' example:
'Dim MyTasks As Outlook.Items
'Set MyTasks = GetItems(olNS, olFolderTasks)
Set GetItems = olNS.GetDefaultFolder(folder).Items
End Function
Private Function Quote(MyText)
' from Sue Mosher's excellent book "Microsoft Outlook Programming"
Quote = Chr(34) & MyText & Chr(34)
End Function
First, there are four ancillary functions: GetOutlookApp, GetNS, GetItems, and Quote. We've seen all of these before.
The main (and hastily named) function ChangeMultiDayToSingleDay first grabs the Items collection from the default Calendar folder. In order to limit the amount of searching, the Restrict Method is used. We restrict by date range by using a specially crafted String. Then the looping begins!
For a given appointment, if it spans across more than one day (End – Start > 1), we'll need to add appointments depending on how big the difference is. So if the difference is three days, we need to create three all-day appointments covering that span of time.
In order to preserve all the elements of the original appointment, the Copy Method is used to create a copy of it. This is to avoid having to iterate through all its properties one by one and copying them into the new appointments. The new appointments' start and end dates are adjusted accordingly (notice how the last appointment is created first).
Finally, the original multi-day appointment is removed from the Calendar, replaced by the appropriate number of single all-day appointments.
Sample usage
Sub TestChangeMultiDay() ChangeMultiDayToSingleDay #3/30/2010#, #5/1/2010# End Sub
About JP
Follow Me