The following code creates a calendar event based on the days and times from contact fields of the contact that is selected....but what I need to do, is I created the Subject using the words Birthday and Full Name, which shows up on the Calender Event,but what I want is that it is the day of of the event but as an "All Day Event", and if possible, it automatically in ever year going forward.
So here is the code and would be great to hear back right away:
Sub Create_Birthday_Calendar_Event_Full_Day3()
Dim objApp As Application
Dim objNS As NameSpace
Dim objFolder As MAPIFolder
Dim objMsg As mailItem
Dim ObjItem As Object
Dim objItems As Object
Dim remoteObj
Dim strDynamicDL As String
Dim ContactName
Dim olns
Dim myFolder
Dim NumItems
Dim myItem
Dim StartDateTime
Dim EndDateTime
Dim ShowAs
Dim itmAppt
Set oContact = ObjItem
Set objApp = CreateObject("Outlook.Application")
Set objNS = objApp.GetNamespace("MAPI")
Set objSelection = objApp.ActiveExplorer.Selection
For Each ObjItem In objSelection
If ObjItem.Class = olContact Then
strDynamicDL = strDynamicDL & ";" & ObjItem.fullname
Else
strDynamicDL = strDynamicDL & ";" & obj.DLName
End If
Next
ContactName = strDynamicDL
Set myFolder = Session.GetDefaultFolder(9).Folders(2)
Set itmAppt = myFolder.Items.Add("IPM.Appointment.Office Calendar Event")
itmAppt.Subject = ContactName & (": ") & ("Birthday")
For Each ObjItem In objSelection
If ObjItem.Class = olContact Then
itmAppt.Location = ("Birthday")
StartDateTime = ObjItem.GetInspector.ModifiedFormPages("General").Controls("OlkDateControl1").value & " " & ObjItem.GetInspector.ModifiedFormPages("General").Controls("OlkTimeControl1").Text
itmAppt.Start = StartDateTime
EndDateTime = ObjItem.GetInspector.ModifiedFormPages("General").Controls("OlkDateControl2").value & " " & ObjItem.GetInspector.ModifiedFormPages("General").Controls("OlkTimeControl2").Text
itmAppt.End = EndDateTime
ShowAs = ObjItem.GetInspector.ModifiedFormPages("General").Controls("combobox13").value
Select Case ShowAs
Case "Free"
ShowAs = 0
Case "Tentative"
ShowAs = 1
Case "Busy"
ShowAs = 2
Case "Out of Office"
ShowAs = 3
End Select
itmAppt.BusyStatus = ShowAs
itmAppt.Links.Add ObjItem
End If
Next
itmAppt.Display
Set objMsg = Nothing
Set ObjItem = Nothing
Set objFolder = Nothing
Set objNS = Nothing
Set objApp = Nothing
End Sub
So here is the code and would be great to hear back right away:
Sub Create_Birthday_Calendar_Event_Full_Day3()
Dim objApp As Application
Dim objNS As NameSpace
Dim objFolder As MAPIFolder
Dim objMsg As mailItem
Dim ObjItem As Object
Dim objItems As Object
Dim remoteObj
Dim strDynamicDL As String
Dim ContactName
Dim olns
Dim myFolder
Dim NumItems
Dim myItem
Dim StartDateTime
Dim EndDateTime
Dim ShowAs
Dim itmAppt
Set oContact = ObjItem
Set objApp = CreateObject("Outlook.Application")
Set objNS = objApp.GetNamespace("MAPI")
Set objSelection = objApp.ActiveExplorer.Selection
For Each ObjItem In objSelection
If ObjItem.Class = olContact Then
strDynamicDL = strDynamicDL & ";" & ObjItem.fullname
Else
strDynamicDL = strDynamicDL & ";" & obj.DLName
End If
Next
ContactName = strDynamicDL
Set myFolder = Session.GetDefaultFolder(9).Folders(2)
Set itmAppt = myFolder.Items.Add("IPM.Appointment.Office Calendar Event")
itmAppt.Subject = ContactName & (": ") & ("Birthday")
For Each ObjItem In objSelection
If ObjItem.Class = olContact Then
itmAppt.Location = ("Birthday")
StartDateTime = ObjItem.GetInspector.ModifiedFormPages("General").Controls("OlkDateControl1").value & " " & ObjItem.GetInspector.ModifiedFormPages("General").Controls("OlkTimeControl1").Text
itmAppt.Start = StartDateTime
EndDateTime = ObjItem.GetInspector.ModifiedFormPages("General").Controls("OlkDateControl2").value & " " & ObjItem.GetInspector.ModifiedFormPages("General").Controls("OlkTimeControl2").Text
itmAppt.End = EndDateTime
ShowAs = ObjItem.GetInspector.ModifiedFormPages("General").Controls("combobox13").value
Select Case ShowAs
Case "Free"
ShowAs = 0
Case "Tentative"
ShowAs = 1
Case "Busy"
ShowAs = 2
Case "Out of Office"
ShowAs = 3
End Select
itmAppt.BusyStatus = ShowAs
itmAppt.Links.Add ObjItem
End If
Next
itmAppt.Display
Set objMsg = Nothing
Set ObjItem = Nothing
Set objFolder = Nothing
Set objNS = Nothing
Set objApp = Nothing
End Sub