VBA Macro in Outlook 2003

It will take be a bit to see if it will work. I will let you know.
Thanks,
-Ron

Well, I ran into a few problems.  First, for my purposes I changed the line If myFolder.Folders(i).Name = "Calendar".  The mastermailItems_ItemAdd is never being triggered.  The second issue, if I am understanding the code correctly, is that I will have to know how many shared folders are open.  Some of our assistants will manage calendars for several people and that number changes depending on who is on vacation.  Finally, even if I had this working, it will not prevent oCalItems_ItemAdd from being triggered on the, user's machine that owns that calendar.

Here is the code that I have

Sub Application_Startup()
Dim x As Long
Dim myshared As Object
 
  'For user's default calendar
   Set oCalItems = Session.GetDefaultFolder(olFolderCalendar).Items
   
  'For Shared Calendar
  Set objNS = Application.GetNamespace("MAPI")
  Set myshared = getStore("Mailbox - ")
  Set mastermailItems = myshared.Items
 
End Sub


unction getStore(shdMbx)
Dim entryID As String
Dim storeID As String
Dim myFolders As Object
Dim myFolder As Object
Dim sTemp As String
Set myFolders = objNS.Folders


For Each myFolder In myFolders
 

If myFolder Is Nothing Then
    MsgBox "Cannot get first Folder object"
    Set myFolders = Nothing
    Exit Function
End If
sTemp = myFolder.Name
'If shdMbx = myFolder.Name Then
    Dim i As Integer
    For i = 1 To myFolder.Folders.Count
        If myFolder.Folders(i).Name = "Calendar" Then
            entryID = myFolder.Folders(i).entryID
            storeID = myFolder.Folders(i).storeID
            Exit For
        End If
    Next

   
   Set getStore = objNS.GetFolderFromID(entryID, storeID)
   
   Set myFolders = Nothing
   Exit Function
'End If
Next
 
End Function

Private Sub mastermailItems_ItemAdd(ByVal Item As Object)
    Call MsgBox(Application.Session.CurrentUser, 0, "I am here")

End Sub


Private Sub oCalItems_ItemAdd(ByVal Item As Object)

Dim lApptHours As Long
Dim csDefaultCalendars As String
Dim sSentOnBehalfOf As String
Dim bNoAging As Boolean
Dim bIknowWhatImDoing As Boolean
.
.
End Sub

the code wont handle multiple delegated mailboxes.

Private withEvents oCalItems as Items registers an event. The function to be fired for this event is mandatorily Private Sub oCalItems_ItemAdd(ByVal Item As Object) (this line was not in the code you show)

code could be:

Private withEvents oCalItems as Items
Private withEvents shrdlItems as Items

Sub Application_Startup()
Dim x As Long
Dim myshared As Object
 
  'For user's default calendar
   Set oCalItems = Session.GetDefaultFolder(olFolderCalendar).Items
   
  'For Shared Calendar
  Set objNS = Application.GetNamespace("MAPI")
  Set myshared = getStore("Mailbox - One Delegated Mailbox ")
  Set shrdItems = myshared.Items
 
End Sub


Function getStore(shdMbx)
Dim entryID As String
Dim storeID As String
Dim myFolders As Object
Dim myFolder As Object
Dim sTemp As String
Set myFolders = objNS.Folders


For Each myFolder In myFolders
 

If myFolder Is Nothing Then
    MsgBox "Cannot get first Folder object"
    Set myFolders = Nothing
    Exit Function
End If
sTemp = myFolder.Name
'If shdMbx = myFolder.Name Then
    Dim i As Integer
    For i = 1 To myFolder.Folders.Count
        If myFolder.Folders(i).Name = "Calendar" Then
            entryID = myFolder.Folders(i).entryID
            storeID = myFolder.Folders(i).storeID
            Exit For
        End If
    Next

   
   Set getStore = objNS.GetFolderFromID(entryID, storeID)
   
   Set myFolders = Nothing
   Exit Function
'End If
Next
 
End Function

Private Sub shrdItems_ItemAdd(ByVal Item As Object)
    Call MsgBox(Application.Session.CurrentUser, 0, "I am here")

End Sub


Private Sub oCalItems_ItemAdd(ByVal Item As Object)

Dim lApptHours As Long
Dim csDefaultCalendars As String
Dim sSentOnBehalfOf As String
Dim bNoAging As Boolean
Dim bIknowWhatImDoing As Boolean
.
.
End Sub

Stefri

Actually the declaration were there.  I just did missed pasting it into this questions.  Did you actually get it to work?

I finally got it working but is still does not address the issue of multiple calendars nor does it address the issue that the ItemAdd event triggers on both the delegates machine and the calendar owner's machine.  Basically if a delegate is creating an appointment the code should only run on that machine.
ANy suggestions?
Thanks,
-Ron

Mutiple issues can be solved only if you know which calendars have to be open: as you have to set a Private WithEvents for each cal, you will need to enumarate them and call the getStore function as many times as cals to monitor
Unfortunately VBA does not accept delaration such as Private WithEvent calItems() as Items

If you do not know, in advance, which cals have to be monitored, you cant use the provided script. But you can tailor it to suit the needs of each delegate (addinfg WithEvents and getStore calls)

If you do not want to get the popup for the user himself, comment all the lines referencing oCalItems.

Stefri

If I comment the lines then it won't work when the owner creates their own appointment.

I suspect the owner knows he is creating an appointment in his personal calendar...
Stefri

First, our code opens a popup that asks for additional information depending on several factors.  The problem is that when a delegate creates the appointment the popup appears on the calendars owner's machine rather than the delegates machine.  If the delegate is entering a lot of appointments for a business trip the owner, understandably get rather annoyed with all the popups.

What is causing the popup to be displayed? Your code or the code in the post?
Stefri

It is part of our code.  We are using custom forms to put in more detailed information about client meetings.  Depending on how the appointment is entered and the contents they may get a popup asking for more information.

I am afraid I cant be of any help as the popup is created by your form.
Cant you detect who is the creator and check this information against the calendar's user  receiving the meeting?
Stefri

Unfortunately, everything seems to come back with the owner not user.  Thanks for trying.

can you post the code

Stefri

It won't include the form.  Can I email the file to you?

against EE policy...

Here is the main part of the code.  I hope this helps.
-Ron

Option Explicit
'Const csDefaultCalendars = "IT"
Dim WithEvents oCalItems As Outlook.Items
Dim WithEvents oEmailItems As Outlook.Items
Dim WithEvents oEmail As Outlook.MailItem
Dim objNS As NameSpace

Private WithEvents mastermailItems As Items



Sub Application_Startup()
Dim x As Long
Dim myShared As Object
   Set oCalItems = Session.GetDefaultFolder(olFolderCalendar).Items
'   Set oEmailItems = Session.GetDefaultFolder(olFolderInbox).Items
 
 'For Shared Calendar
  'Set objNS = Application.GetNamespace("MAPI")
  'Set myShared = getStore(".....")
  'Set mastermailItems = myShared.Items
   
   '
'    Set oEmail = oEmailItems.GetFirst
   
'   For x = 1 To 5 ' oEmailItems.Count
'    Call MsgBox(oEmail, 0, oEmail.ReceivedTime)
'    Call MsgBox(oEmail, 0, oEmail.UnRead)
'    Set oEmail = oEmailItems.GetNext
   'Set oEmail = oEmailItems.
   ' oEmail = oEmailItems.GetNext
'   Next x
End Sub

Function getStore(shdMbx)
Dim entryID As String
Dim storeID As String
Dim myFolders As Object
Dim myFolder As Object
Dim sTemp As String
Set myFolders = objNS.Folders


For Each myFolder In myFolders
 

If myFolder Is Nothing Then
    MsgBox "Cannot get first Folder object"
    Set myFolders = Nothing
    Exit Function
End If
sTemp = myFolder.Name
If shdMbx = myFolder.Name Then
    Dim i As Integer
    For i = 1 To myFolder.Folders.Count
        If myFolder.Folders(i).Name = "Calendar" Then
            entryID = myFolder.Folders(i).entryID
            storeID = myFolder.Folders(i).storeID
            Exit For
        End If
    Next

   
   Set getStore = objNS.GetFolderFromID(entryID, storeID)
   
   Set myFolders = Nothing
   Exit Function
End If
Next
 
End Function
Private Sub mastermailItems_ItemAdd(ByVal Item As Object)
    Call MsgBox(Application.Session.CurrentUser, 0, "I am here")

End Sub


Private Sub oCalItems_ItemAdd(ByVal Item As Object)

Dim lApptHours As Long
Dim csDefaultCalendars As String
Dim sSentOnBehalfOf As String
Dim bNoAging As Boolean
Dim bIknowWhatImDoing As Boolean


'    Call MsgBox(Item.RequiredAttendees, vbOKOnly)
'    If (Item.BillingInformation = "" And Len(Item.RequiredAttendees) <= 1) Then  ' And Item.SentOnBehalfOfName <> Item.Organizer) Then
'Item.GetInspector.Display
On Error Resume Next

bIknowWhatImDoing = Item.UserProperties("bIKnowWhatImDoing")

'Call MsgBox(Application.Session.CurrentUser, 0, Item.Organizer)
If (Item.Mileage = "" And Application.Session.CurrentUser = Item.Organizer And Not bIknowWhatImDoing) Then
    bCanceled = False
    bEditItem = False

Item.Mileage = Item.BillingInformation
' And Item.SentOnBehalfOfName <> Item.Organizer) Then
        ' First save previous group calendar list so we know what calendars
        ' to delete from.
'       If (lApptHours >= 24) Then
'           Item.BusyStatus = olOutOfOffice
'       Else
'           Item.BusyStatus = olBusy
'       End If
        iBusyStatus = Item.BusyStatus
        sCategory = Item.Categories
        'If (Item.Sensitivity = olPrivate) Then
        '    bPrivate = True
        'End If
        If (Item.Sensitivity = olPrivate) Then
            bPrivate = True
        Else
            bPrivate = False
        End If
        bClientMeeting = Item.UserProperties("bClientMeeting")
        bSeparateAccount = Item.UserProperties("bSeparateAccount")
        bVisitor = Item.UserProperties("bVisitorsCalendar")
        iBusyStatus = Item.BusyStatus
        bInOffice = Item.UserProperties("bInOffice")
        bIncludeReports = Item.UserProperties("bIncludeReports")
        sClientAccountNumber = Item.UserProperties("sClientAccountNumber")
        sClientName = Item.UserProperties("sClientName")
        sPMsAttending = Item.UserProperties("sClientMeetingAttendees")
        sReportedBy = Item.UserProperties("sReportedBy")
        strSubject = Item.Subject
        dStart = Item.Start
        dEnd = Item.End
        sLocation = Item.Location

       
        frmDepartmentalCalendar.Show
'        Item.Mileage = Item.BillingInformation
       
        Item.BusyStatus = iBusyStatus

       
        If (bClientMeeting) Then
            If (bSeparateAccount) Then
                strSubject = "Acct#: " & sClientAccountNumber & ", Client Name: " & sClientName & ", PA's: " & sPMsAttending & ", Reported By: " & sReportedBy
            Else
                strSubject = "Client Name: " & sClientName & ", PA's: " & sPMsAttending & ", Reported By: " & sReportedBy
            End If
            If (bIncludeReports) Then
                strSubject = strSubject & ", Incl. Standard Reports"
            End If
        End If
        Item.Subject = strSubject

        'Use this field to prevent updating of form - possible an MS bug
        ' get old value
        bNoAging = Item.NoAging
        Item.NoAging = True
            If (bVisitor) Then
                Item.UserProperties("bVisitorsCalendar").Value = True
            Else
                Item.UserProperties("bVisitorsCalendar").Value = False
            End If
            Item.Categories = sCategory
            If (bPrivate) Then
                Item.Sensitivity = olPrivate
            Else
                Item.Sensitivity = olNormal
            End If
            Item.UserProperties("bClientMeeting").Value = bClientMeeting
            Item.UserProperties("bSeparateAccount").Value = bSeparateAccount
            'Item.UserProperties("bVisitorsCalendar") = bVisitor
            Item.BusyStatus = iBusyStatus
            Item.UserProperties("bInOffice") = bInOffice
            Item.UserProperties("bIncludeReports") = bIncludeReports
            Item.UserProperties("sClientAccountNumber") = sClientAccountNumber
            Item.UserProperties("sClientName") = sClientName
            Item.UserProperties("sClientMeetingAttendees") = sPMsAttending
            Item.UserProperties("sReportedBy") = sReportedBy
           
        ' reset
        Item.NoAging = bNoAging
       
        If (bCanceled) Then
            Item.Delete
        ElseIf (bEditItem) Then
            Item.GetInspector.Display
        Else
'            Item.Close olPromptForSave
            Item.GetInspector.Close olDiscard
            Item.Save
        End If
  End If
NoShow:
End Sub
Sub GetCalendar()
frmUserCalendar.Show
End Sub