[Kamijudo]

I have several clients and e-mail accounts with each one that I'm forced to deal with. When I'm with a particular client I have to schedule a meeting -- however, the calendar in their outlook/exchange wouldn't be synchronized with my other calendars -- client2, and client3.

1. However, the calendar items created by this macro are not always "stable" soemtimes they show and then "cancel" by themselves, other times they just don't show -- even when everyone accepts them.

2. I get messages in my inboxe for every calendar item I create -- that just fills my in box, which didn't used to happen (before I wrote the macro) and created a calendar item and added addressees by hand.

I cut and pasted this VB macro from other macros on this and other sites. This Macro works about 70% of the time. I found that I had to set -- Item.MeetingStatus = olMeeting -- to get the Meeting item to save and feel as though there's something else VERY simple that I'm missing.

Any help would be greatly appreciated.

P.S. Do not fool around with ItemChange to do something similar to this -- the malestrom of messages nearly locked up my machine.


--- Start of code in ThisOutlookSession ---
Option Explicit
Public WithEvents MyOlItems As Outlook.Items
Public MyInProcess As Integer

Private Sub Initialize_Handler()
Set MyOlItems = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderCalendar).Items
End Sub

Private Sub Application_MAPILogonComplete()
'Initialize_Handler
End Sub

Private Sub Application_Startup()
Initialize_Handler
Debug.Print "*** Startup ***"
End Sub

Private Sub MyOlItems_ItemAdd(ByVal Item As Object)

'Exit if already processing a mail item
If MyInProcess Then Exit Sub
MyInProcess = -1

Debug.Print "* A -";
ProcessCalendarItem Item

MyInProcess = 0
End Sub


Private Function ProcessAddress(ByVal Item As Outlook.AppointmentItem, ByVal MyAddress As String) As

Integer
Dim MyRecipient As Recipient
Dim MyFlag As Integer

MyAddress = LCase(Trim(MyAddress))

'Search for my Address in the list of addressees -- check out SMTP
MyFlag = -1
For Each MyRecipient In Item.Recipients
If InStr(1, LCase(MyRecipient.AddressEntry), MyAddress) Then
MyFlag = 0
Exit For
End If
Next

'Add my Address to the list of addressees
If MyFlag Then
Item.Recipients.Add MyAddress
Item.MeetingStatus = olMeeting 'Have to add this to make the address take??
Item.Save
End If

ProcessAddress = MyFlag

End Function



Private Sub ProcessCalendarItem(ByVal Item As Object)

Dim MyFlag As Integer

If Item.Class <> olAppointment Then
Debug.Print Item.Class; " <-- Not Appointment Item"
Exit Sub
End If

Debug.Print Item.Recipients.Count

MyFlag = ProcessAddress(Item, "(E-Mail Removed)")
MyFlag = MyFlag + ProcessAddress(Item, "(E-Mail Removed)")
MyFlag = MyFlag + ProcessAddress(Item, "(E-Mail Removed)")
MyFlag = MyFlag + ProcessAddress(Item, "(E-Mail Removed)")

If MyFlag Then Item.Send

End Sub
--- End of code ---