VBA created events not created as AllDay

Hi,

I have a simple form that captures the name of someone (for their brithday events) and their date of birth.

The routine below then creates the next 10 years worht of birthdays including their age in the subject line so not recurring appointments but 10 separate ones.

So far so good. However they are being created with start and end date the same but time 00:00 therefore not showing in the AllDay event bar. When I got to Calendar and create a table view that include the AllDay field it is ticked but if I open an appointment it is not ticked and the time is 00:00...

Any ideas??

Thanks

Sub Create_Celebration()

    Set oApp = New Outlook.Application
    Set oNMS = oApp.GetNamespace("MAPI")
    Set oExpl = oApp.ActiveExplorer
    Set oExpl.CurrentFolder = oNMS.GetDefaultFolder(olFolderCalendar)
    Set oFldr = oExpl.CurrentFolder
    Set oItems = oFldr.Items

    If frmBirthday.txtPrefix.Value = "" Then Exit Sub

    If MsgBox(frmBirthday.txtPrefix.Value & "'s Birthday is " & frmBirthday.MyCal.Value, vbYesNo, "Confirm") = vbYes Then
        'Create the Appts
        For i = 2010 To 2020
            Set oCB = oExpl.CommandBars.FindControl(, 1106)
            If oCB Is Nothing Then Exit Sub
            oCB.Execute
            Set oAppt = Application.ActiveInspector.CurrentItem
            oAppt.AllDayEvent = True
            Set oApptCustom = oFldr.Items.Add("IPM.Appointment")
            With oApptCustom
                .Subject = frmBirthday.txtPrefix.Value & "'s Birthday (" & (i - Right(frmBirthday.MyCal.Value, 4)) & ")"
                .Start = CDate(Left(frmBirthday.MyCal.Value, 2) & "/" & Mid(frmBirthday.MyCal.Value, 4, 2) & "/" & i)
                .End = CDate(Left(frmBirthday.MyCal.Value, 2) & "/" & Mid(frmBirthday.MyCal.Value, 4, 2) & "/" & i)
                .AllDayEvent = True
                .BusyStatus = olFree
                .Categories = "Celebration"
                .Importance = olImportanceNormal
                .Sensitivity = olPrivate
                .Save
            End With
            oAppt.Delete
        Next i
    End If
    frmBirthday.txtPrefix.Value = ""

    Set oAppt = Nothing
    Set oItems = Nothing
    Set oSelect = Nothing
    Set oFldr = Nothing
    Set oExpl = Nothing
    Set oNMS = Nothing
    Set oApp = Nothing

End Sub

Select allOpen in new window