Solved

VBA created events not created as AllDay

Posted on 2010-11-16
5
590 Views
Last Modified: 2012-05-10
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

Open in new window

0
Comment
Question by:Charltp5
  • 3
  • 2
5 Comments
 
LVL 76

Expert Comment

by:David Lee
ID: 34151835
Hi, Charltp5.

I'm confused a bit by the code.  What is the purpose of lines 15 through 18?
0
 
LVL 1

Author Comment

by:Charltp5
ID: 34154256
Yes you're right - I think it was cobbled together and I changed the methodology for creating the appointment. Suffice it to say I have removed the code and still get the same behaviour.

New code and screen cast attached...
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 oAppt = oFldr.Items.Add("IPM.Appointment")

            With oAppt

                .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

        Next i

    End If

    frmBirthday.txtPrefix.Value = ""



    Set oAppt = Nothing

    Set oItems = Nothing

    Set oFldr = Nothing

    Set oExpl = Nothing

    Set oNMS = Nothing

    Set oApp = Nothing



End Sub

Open in new window

Charltp5-370715.flv
0
 
LVL 76

Accepted Solution

by:
David Lee earned 500 total points
ID: 34154349
Remove line #19.
0
 
LVL 1

Author Closing Comment

by:Charltp5
ID: 34154986
And that's is why you're a genius!!! Thanks.
0
 
LVL 76

Expert Comment

by:David Lee
ID: 34155021
Thanks and you're welcome.
0

Featured Post

Is Your Active Directory as Secure as You Think?

More than 75% of all records are compromised because of the loss or theft of a privileged credential. Experts have been exploring Active Directory infrastructure to identify key threats and establish best practices for keeping data safe. Attend this month’s webinar to learn more.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

What does UTC stand for?  “Coordinated Universal Time” – Think of this as the true time on Planet Earth that never changes with the exception of minor leap seconds here and there to account for the changes in the planet's rotation.   What does th…
Following basic email etiquette rules will help you write a professional email and achieve a good, lasting impression with your contacts.
To add imagery to an HTML email signature, you have two options available to you. You can either add a logo/image by embedding it directly into the signature or hosting it externally and linking to it. The vast majority of email clients display l…
This video shows how to remove a single email address from the Outlook 2010 Auto Suggestion memory. NOTE: For Outlook 2016 and 2013 perform the exact same steps. Open a new email: Click the New email button in Outlook. Start typing the address: …

862 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

23 Experts available now in Live!

Get 1:1 Help Now