Solved

VBA created events not created as AllDay

Posted on 2010-11-16
5
594 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
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 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

Independent Software Vendors: We Want Your Opinion

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

Question has a verified solution.

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

Suggested Solutions

Title # Comments Views Activity
fit to print in single page 5 37
Outlook PST (cloud) backup 3 86
Outlook Automation in Access Using "Find" 2 57
Exchange Online Archive 2 23
Are you unable to connect or configure Hotmail email account in Microsoft Outlook 2010, 2007? Or Outlook.com emails are not downloading to Outlook? Lets’ see the problem and resolve Outlook Connector error syncing folder hierarchy (0x8004102A).
Changing a few Outlook Options can help keep you organized!
Get people started with the process of using Access VBA to control Outlook using automation, Microsoft Access can control other applications. An example is the ability to programmatically talk to Microsoft Outlook. Using automation, an Access applic…
A short tutorial showing how to set up an email signature in Outlook on the Web (previously known as OWA). For free email signatures designs, visit https://www.mail-signatures.com/articles/signature-templates/?sts=6651 If you want to manage em…

734 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