Solved

VBA Macro in Outlook 2003

Posted on 2004-10-13
20
776 Views
Last Modified: 2012-06-27
I have a macro that opens a popup window whenever a user adds an appointment to their calendar.  For the most part it is working well.  The problem occurs when a delegate creates an appointment on the same calendar the popup window only appears on the calendar's owner no the delegate.  Is there a field I could use so that the popup  opens on the workstation that is creating the appointment?  Currently I am using the sub oCalItems_ItemAdd to detect when an item is added.
0
Comment
Question by:rkanter
  • 10
  • 8
20 Comments
 
LVL 13

Accepted Solution

by:
stefri earned 500 total points
ID: 12302278
Would you check a previous posting
Just change the Inbox to Contacts in getStore sub and the name of the delegated mailbox in Application_Startup
http://www.experts-exchange.com/Applications/MS_Office/Outlook/Q_20465183.html

Stefri
0
 

Author Comment

by:rkanter
ID: 12303266
It will take be a bit to see if it will work. I will let you know.
Thanks,
-Ron
0
 

Author Comment

by:rkanter
ID: 12309395
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
0
 
LVL 13

Expert Comment

by:stefri
ID: 12323548
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
0
 

Author Comment

by:rkanter
ID: 12340485
Actually the declaration were there.  I just did missed pasting it into this questions.  Did you actually get it to work?
0
 

Author Comment

by:rkanter
ID: 12340869
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
0
 
LVL 13

Expert Comment

by:stefri
ID: 12342238
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
0
 

Author Comment

by:rkanter
ID: 12342824
If I comment the lines then it won't work when the owner creates their own appointment.
0
 
LVL 13

Expert Comment

by:stefri
ID: 12349750
I suspect the owner knows he is creating an appointment in his personal calendar...
Stefri
0
Threat Intelligence Starter Resources

Integrating threat intelligence can be challenging, and not all companies are ready. These resources can help you build awareness and prepare for defense.

 

Author Comment

by:rkanter
ID: 12350746
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.
0
 
LVL 13

Expert Comment

by:stefri
ID: 12362052
What is causing the popup to be displayed? Your code or the code in the post?
Stefri
0
 

Author Comment

by:rkanter
ID: 12373259
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.
0
 
LVL 13

Expert Comment

by:stefri
ID: 12373475
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
0
 

Author Comment

by:rkanter
ID: 12373565
Unfortunately, everything seems to come back with the owner not user.  Thanks for trying.
0
 
LVL 13

Expert Comment

by:stefri
ID: 12373585
can you post the code

Stefri
0
 

Author Comment

by:rkanter
ID: 12373662
It won't include the form.  Can I email the file to you?
0
 
LVL 13

Expert Comment

by:stefri
ID: 12374691
against EE policy...
0
 

Author Comment

by:rkanter
ID: 12400959
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
0

Featured Post

How to improve team productivity

Quip adds documents, spreadsheets, and tasklists to your Slack experience
- Elevate ideas to Quip docs
- Share Quip docs in Slack
- Get notified of changes to your docs
- Available on iOS/Android/Desktop/Web
- Online/Offline

Join & Write a Comment

Use these top 10 tips to master the art of email signature design. Create an email signature design that will easily wow recipients, promote your brand and highlight your professionalism.
Not sure what the best email signature size is? Are you worried about email signature image size? Follow this best practice guide.
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…
To add imagery to an HTML email signature, you have two options available to you. You can either add a logo/image by embedding it directly into the signature or hosting it externally and linking to it. The vast majority of email clients display l…

758 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

Need Help in Real-Time?

Connect with top rated Experts

21 Experts available now in Live!

Get 1:1 Help Now