Outlook 2007 All Day Event

[Diane Poremsky]

No, I'm swamped with work and way behind, thanks to a 4 hour support call.

 

[LMS]

I am waiting!!

 

[LMS]

Update tonight please?

 

[Diane Poremsky]

I probably won't get a chance before Friday at the earliest, if that, and we have plans for both Sat and Sunday, so i won't have much time before Monday. Sorry. If you can post the code that you used before, it will help - i won't have to go looking for it.

 

[LMS]

The following code is how I delete a field of a contact that I open up from the email and or from the folder...and you gave what add to it so it can't do when I just open up from the email I receive.....so just need to know what to change and/or add to the birthday code that is in this Thread:

Sub DeleteStatusDate()
Dim objApp As Application
Dim objNS As NameSpace
Dim objFolder As MAPIFolder
Dim ObjItem As Object
Set objApp = CreateObject("Outlook.Application")
Set objNS = objApp.GetNamespace("MAPI")
On Error Resume Next
If TypeName(objApp.ActiveWindow) = "Inspector" Then
Set ObjItem = objApp.ActiveInspector.currentItem
ObjItem.UserProperties("Status Date") = ObjItem.UserProperties("NoneDate")

ObjItem.Save
GoTo Leave
End If
Set objSelection = objApp.ActiveExplorer.Selection
For Each ObjItem In objSelection
ObjItem.UserProperties("Status Date") = ObjItem.UserProperties("NoneDate")
ObjItem.Save
Next
Leave:
Set ObjItem = Nothing
Set objFolder = Nothing
Set objNS = Nothing
Set objApp = Nothing
End Sub

 

[LMS]

The following code is how I delete a field of a contact that I open up from the email and or from the folder...and you gave what add to it so it can't do when I just open up from the email I receive.....so just need to know what to change and/or add to the birthday code that is in this Thread:

Sub DeleteStatusDate()
Dim objApp As Application
Dim objNS As NameSpace
Dim objFolder As MAPIFolder
Dim ObjItem As Object
Set objApp = CreateObject("Outlook.Application")
Set objNS = objApp.GetNamespace("MAPI")
On Error Resume Next
If TypeName(objApp.ActiveWindow) = "Inspector" Then
Set ObjItem = objApp.ActiveInspector.currentItem
ObjItem.UserProperties("Status Date") = ObjItem.UserProperties("NoneDate")

ObjItem.Save
GoTo Leave
End If
Set objSelection = objApp.ActiveExplorer.Selection
For Each ObjItem In objSelection
ObjItem.UserProperties("Status Date") = ObjItem.UserProperties("NoneDate")
ObjItem.Save
Next
Leave:
Set ObjItem = Nothing
Set objFolder = Nothing
Set objNS = Nothing
Set objApp = Nothing
End Sub

 

[LMS]

Any update today maybe?

 

[LMS]

To All,

I looked into it, and did the following and it takes care of what I asked:

Sub Create_Birthday_Calendar_Event_Full_Day()
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
Dim myPattern As RecurrencePattern

Set oContact = ObjItem
Set objApp = CreateObject("Outlook.Application")
Set objNS = objApp.GetNamespace("MAPI")
Set objSelection = objApp.ActiveExplorer.Selection
On Error Resume Next

If TypeName(objApp.ActiveWindow) = "Inspector" Then
Set ObjItem = objApp.ActiveInspector.currentItem
End If
If ObjItem.Class = olContact Then
strDynamicDL = strDynamicDL & ObjItem.fullname
Else
strDynamicDL = strDynamicDL & ";" & obj.DLName
End If
ContactName = strDynamicDL

Set myFolder = Session.GetDefaultFolder(9).Folders(2)
Set itmAppt = myFolder.Items.Add("IPM.Appointment.Office Calendar Event")
itmAppt.Subject = ContactName & (": ") & ("Birthday")
Set objSelection = objApp.ActiveInspector.currentItem

For Each ObjItem In objSelection

With itmAppt
.AllDayEvent = True
.Subject = ContactName & (": ") & ("Birthday")
StartDateTime = ObjItem.GetInspector.ModifiedFormPages("General").Controls("ComboBox30")

itmAppt.Start = StartDateTime
End With
Set myPattern = itmAppt.GetRecurrencePattern
With myPattern
.RecurrenceType = olRecursYearly


End With
itmAppt.Save
itmAppt.Display


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
Next
itmAppt.Display

Set objMsg = Nothing
Set ObjItem = Nothing
Set objFolder = Nothing
Set objNS = Nothing
Set objApp = Nothing
End Sub