home | get Sue’s code | forums | share code | registration

Outlook Technologies

Outlook Forms

Languages

Samples

More Outlook Resource Sites

Microsoft Developer Network (MSDN)

FAQs and other general resources

share code 09-Feb-2010 07:16

Looking for help with Outlook programming projects — VSTO, add-ins, VBA, custom Outlook forms, etc.? You′ve come to the right place!

NEW! >> Subscribe to this site via RSS. For more RSS options, see the complete list of feeds on our main news page.

Code level: advanced Code area: Outlook Expert Techniques Printer Friendly Version
Title: How to Add/Change Recipients in an Outlook Agent
Description: This is a work in progress, but works for most of the things we want it to do.
Date: 22-May-2003 06:07
Code level: advanced
Code area: Outlook Expert Techniques
Posted by: Joel Foudy
Body: Attribute VB_Name = "Module1" <SCRIPT RunAt=Server Language=VBScript> ' USERS SCRIPT ' '-----------------------------------------------------------------' ' Version 07 AutoAccept NoTraceMessages Autoconfirm ' Last Modified 5/15/2003 ' THIS CODE AND INFORMATION IS PROVIDED "AS IS" WITHOUT WARRANTY OF ' ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING BUT NOT LIMITED ' TO THE IMPLIED WARRANTIES OF MERCHANTABILITY AND/OR FITNESS FOR A ' PARTICULAR PURPOSE ' ' MICROSOFT DOES NOT SUPPORT THE USE OF AGENTS FOR AUTOACCEPT '-----------------------------------------------------------------' '-----------------------------------------------------------------' ' Change History ' ' Version 01 ************************************************** ' Modifications were made to a script supplied by Microsoft for ' Great West Casualty to auto-accept meeting. ' ' ' Version 02 (code changes by Jeff Schmitz) ***************** ' Enhancements were added to the script to send a confirmation ' message to the person who has had a meeting added to their ' calendar. A new booleen variable was added (blnIsFree) which ' is used to determine when a confirmation should be sent. A ' new subroutine was added (SendNewEventMsg) to actually send ' the confirmation message. ' ' ' Version 03 (1/16/2002 - code changes by Jeff Schmitz)***** ' All of the existing code associated with the trace feature has ' been prepended with the following comment: ' 'TraceOff ' ' Code was changed in the "FindConflicts" subroutine to fix a ' potential problem with date comparisons. The function call to ' "FormatDateTime" was replaced by the "CDate" function call. ' ' One of the existing "DebugAppend" calls in the "FindConflicts" ' subroutine was enabled to facilitate testing of the reported ' problems with meetings being accepted incorrectly. ' ' ' Version 04 (1/18/2002 - code changes by Jeff Schmitz)***** ' All of the existing code associated with the debug feature has ' been prepended with the following comment: ' 'DebugOff ' ' Version 05 (2/12/2002 - code changes by Jeff Schmitz)***** ' This feature will treat a meeting of "Tentative" the same as a ' "Free" status meeting for the purpose of finding conflicts. ' 'Ver 05 ' ' Version 06 (2/12/2002 - code changes by Jeff Schmitz)***** ' This feature will ignore "FindConflict" checking if the meeting ' is of the recurring type. ' 'Ver 06 ' ' Version 07 (5/16/2003 - code changes by Joel FOudy)***** ' Sets reminders on by default ' Changed the appearance of the meeting notification messages ' If the Users profile PR_EMS_AB_EXTENSION_ATTRIBUTE_7 = "NO REMINDER" a reminder will not be set. ' '-----------------------------------------------------------------' 'Option Explicit ' GLOBAL VARIABLES '-----------------------------------------------------------------' Dim g_sDiagLog 'Debug String for Agent Log. 'TraceOffDim g_sTraceMsg 'Debug String for Trace Message. 'TraceOffDim g_blnTraceMsg 'Trace messages will be posted for each event Dim g_intMaxRecur Dim strBooleans ' CONSTANTS '-----------------------------------------------------------------' ' Class Property Const CdoMeetingItem = 27 'MeetingItem object ' MeetingType for MeetingItem object Const CdoMeetingRequest = 1 'Request ' Respond Method for MeetingItem object Const CdoResponseAccepted = 3 'Accepted Const CdoResponseDeclined = 4 'Declined ' BusyStatus Property for AppointmentItem object Const CdoFree = 0 'Free Const CdoTentative = 1 'Tentative Const CdoBusy = 2 'Busy Const CdoOutOfOffice = 3 'Out of office ' MeetingStatus Property of AppointmentItem object Const CdoMeeting = 1 'Meeting Const CdoMeetingReceived = 3 'Received Const CdoMeetingCanceled = 5 'Canceled ' RecurrenceType Property of RecurrencePattern object Const CdoRecurTypeDaily = 0 'Daily Const CdoRecurTypeWeekly = 1 'Weekly Const CdoRecurTypeMonthly = 2 'Monthly Const CdoRecurTypeMonthlyNth = 3 'MonthlyNth Const CdoRecurTypeYearly = 5 'Yearly Const CdoRecurTypeYearlyNth = 6 'YearlyNth ' Max number of Months to check for conflicts Const MaxYearlyRecur = 120 'yearly recurrence Const MaxMonthlyRecur = 48 'monthly recurrence Const MaxWeeklyRecur = 24 'weekly recurrence Const MaxDailyRecur = 24 'daily recurrence ' Address List Const CdoAddressListGAL = 0 'Global Address List ' Display Type Const CdoPR_DISPLAY_TYPE = &H39000003 'Display Type Tag Const CdoDistList = 1 'Public Distribution List ' MAPI Property Tags Const CdoPR_START_DATE = &H600040 'Start Date for filter Const CdoPR_END_DATE = &H610040 'End Date for filter Const CdoPR_OWNER_APPT_ID = &H620003 'Unique identifier for the appointment Const CdoPR_SENT_REPRESENTING_ENTRYID = &H410102 'Address Entry Identifier of the represented sender Const CdoPR_SENT_REPRESENTING_NAME = &H42001E 'Display Name of the represented sender Const CdoPR_RCVD_REPRESENTING_ENTRYID = &H430102 'Address Entry Identifier of the represented receiver Const CdoPR_RCVD_REPRESENTING_NAME = &H44001E 'Display Name of the represented receiver ' Exchange Object Custom Attributes (self explanatory) Const PR_EMS_AB_EXTENSION_ATTRIBUTE_1 = &H802D001E Const PR_EMS_AB_EXTENSION_ATTRIBUTE_2 = &H802E001E Const PR_EMS_AB_EXTENSION_ATTRIBUTE_3 = &H802F001E Const PR_EMS_AB_EXTENSION_ATTRIBUTE_4 = &H8030001E Const PR_EMS_AB_EXTENSION_ATTRIBUTE_5 = &H8031001E Const PR_EMS_AB_EXTENSION_ATTRIBUTE_6 = &H8032001E Const PR_EMS_AB_EXTENSION_ATTRIBUTE_7 = &H8033001E Const PR_EMS_AB_EXTENSION_ATTRIBUTE_8 = &H8034001E Const PR_EMS_AB_EXTENSION_ATTRIBUTE_9 = &H8035001E Const PR_EMS_AB_EXTENSION_ATTRIBUTE_10 = &H8036001E ' CDO Error Codes Const CdoE_NO_SUPPORT = &H80040102 Const CdoE_NOT_FOUND = &H8004010F Const CdoE_TOO_COMPLEX = &H80040117 ' EVENT HANDLERS '-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-' '-----------------------------------------------------------------' ' Name: Folder_OnMessageCreated ' Desc: This event fires when a new message is added ' to the folder '-----------------------------------------------------------------' Public Sub Folder_OnMessageCreated() On Error Resume Next Dim aryDistLists() Dim aryFields Dim blnAcceptRecur 'Allow recurring meeting requests Dim blnConfigByForm 'Use posted form for configuration Dim blnDistList 'Object is a distribution List Dim blnMemberFound 'Entry found in distribution lists Dim blnNoReminders 'Remove reminders from all appt.s Dim blnPrefixSubject 'Prefix the appt subject w/ organizer's name Dim blnRestrictByDL 'Restrict by distribution lists Dim blnSetAllAsBusy 'Schedule all appt.s as busy Dim blnSuccess 'Success or failure Dim blnIsFree 'True if IsFree returns true Dim colFolders 'Folder collection Dim colMsgs 'Message collection Dim dtmConflict 'First conflict found on recurring appointment Dim intPos 'InStr integer position Dim objAddressList 'Address list Dim objAppt 'Appointment object Dim objCdoSession 'CDO session Dim objContact 'Address entry of the resource's contact Dim objDistList 'Distribution list object Dim objMsg 'Message object Dim objMtg 'Meeting object Dim objMtgResp 'Meeting response object Dim objUser 'Current User object 'TraceOffDim strAccepted 'Free or Busy for trace message Dim strContactName 'Resource contact's display name Dim strDistList 'Display Name of a DL used for restriction Dim strDistListNames 'Display Names of the DL's used for restriction Dim strOrganizer 'Meeting Organizer Display Name Dim strSenderName 'Sender's Name stored as a string Dim strType 'Type of request for trace message Dim strUserName 'User Name stored as string Dim aryBooleans() 'TraceOffg_blnTraceMsg = True 'DebugOffCall DebugAppend("AutoAccept", True, False) 'DebugOffCall DebugAppend(":Start - Folder_OnMessageCreated " & Time, True, False) blnConfigByForm = False Set objCdoSession = EventDetails.Session 'Session Object Set objUser = objCdoSession.CurrentUser 'CurrentUser Object 'blnSuccess = SetMsgCollection(objCdoSession, "AutoAccept", True, colMsgs) If colMsgs.Count > 0 Then For Each objMsg In colMsgs If objMsg.Subject = "AutoAccept Configuration" Then 'TraceOffg_blnTraceMsg = objMsg.Fields("Post Trace Messages") blnSetAllAsBusy = objMsg.Fields("Book All As Busy") blnAcceptRecur = objMsg.Fields("Accept Recurring Appts") blnRestrictByDL = objMsg.Fields("Restrict By DL") blnNoReminders = objMsg.Fields("Remove Reminders") blnConfigByForm = objMsg.Fields("Config By Form") blnPrefixSubject = objMsg.Fields("Prefix Appt Subject") g_intMaxRecur = objMsg.Fields("Recur Max Months") strDistListNames = Trim(objMsg.Fields("Distribution Lists")) strContactName = Trim(objMsg.Fields("Resource Contact")) If Err Then Err.Clear Exit For End If Next Set objMsg = Nothing Set colMsgs = Nothing End If If blnConfigByForm = False Then strBooleans = Trim(objUser.Fields(PR_EMS_AB_EXTENSION_ATTRIBUTE_7)) If Err = CdoE_NOT_FOUND _ Or Left(strBooleans, 4) <> "True" _ And Left(strBooleans, 5) <> "False" Then Err.Clear 'DebugOffCall DebugAppend("!No Configuration Form or Configuration Custom Attributes", False, False) 'DebugOffCall DebugAppend("!Using Defaults for Configuration", False, False) blnRestrictByDL = False blnNoReminders = True blnAcceptRecur = True blnSetAllAsBusy = True blnPrefixSubject = False 'TraceOffg_blnTraceMsg = True g_intMaxRecur = 0 Else 'DebugOffCall DebugAppend(" Using Exchange custom attributes for configuration", False, False) Call CreateArray(strBooleans, ", ", aryBooleans) blnRestrictByDL = CBool(aryBooleans(0)) blnNoReminders = CBool(aryBooleans(1)) blnAcceptRecur = CBool(aryBooleans(2)) blnSetAllAsBusy = CBool(aryBooleans(3)) blnPrefixSubject = CBool(aryBooleans(4)) 'TraceOffg_blnTraceMsg = CBool(aryBooleans(5)) g_intMaxRecur = CInt(aryBooleans(6)) If blnRestrictByDL = True Then strDistListNames = Trim(objUser.Fields(PR_EMS_AB_EXTENSION_ATTRIBUTE_9)) 'Custom Attribute has no value If Err = CdoE_NOT_FOUND Then Err.Clear End If strContactName = Trim(objUser.Fields(PR_EMS_AB_EXTENSION_ATTRIBUTE_10)) 'Custom Attribute has no value If Err = CdoE_NOT_FOUND Then Err.Clear End If End If End If Else 'DebugOffCall DebugAppend(" Using form for configuration", False, False) End If strUserName = CStr(objUser.Name) 'Store UserName once as string. 'Get Incoming Meeting Message. Set objMtg = objCdoSession.GetMessage(EventDetails.MessageID, Null) strSenderName = CStr(objMtg.Sender.Name) 'Store Sender's Name once as string. 'if UCase(objMtg.Subject) = "SET REMINDER OFF" Then ' objMtg.Subject = "Proccessed Reminder to OFF" ' objMtg.Update ' SET objUser.Fields(PR_EMS_AB_EXTENSION_ATTRIBUTE_7) = "NO REMINDER"' 'elseif UCase(objMtg.Subject) = "SET REMINDER ON" Then ' objMtg.Subject = "Proccessed Reminder to ON" ' objMtg.Update' ' SET objUser.Fields(PR_EMS_AB_EXTENSION_ATTRIBUTE_7) = "" 'End if 'If Restricting users of this resource. If blnRestrictByDL Then 'DebugOffCall DebugAppend(" Restrict By Distribution List", False, False) blnMemberFound = False 'Default is not found. Set objAddressList = objCdoSession.GetAddressList(CdoAddressListGAL) If strDistListNames <> "" Then Call CreateArray(strDistListNames, "; ", aryDistLists) For Each strDistList In aryDistLists Call IsDList(strDistList, objAddressList, objDistList, blnDistList) If blnDistList Then 'DebugOffCall DebugAppend(" Found Distribution List: " & _ 'DebugOff strDistList, False, False) 'see if sender is in the DL Call CheckDList(objDistList, objMtg, blnMemberFound) If blnMemberFound Then 'DebugOffCall DebugAppend(" Found Sender in Distribution List: " & _ 'DebugOff objMtg.Sender.Name, False, False) Exit For End If Else 'DebugOffCall DebugAppend("!Could not obtain the configured Distribution List: " & _ 'DebugOff strDistList, True, False) 'DebugOffCall DebugAppend("!Accepting All Requests", True, False) blnMemberFound = True 'accept all requests. Exit For End If Next Else 'DebugOffCall DebugAppend("!Distribution List is not defined", True, False) 'DebugOffCall DebugAppend("!Accepting All Requests", True, False) blnMemberFound = True 'accept all requests. End If 'If Contact is defined AND user is not allowed to use this resource. If strContactName <> "" _ And blnMemberFound = False Then Set objContact = objAddressList.AddressEntries(strContactName) If LCase(objContact.Name) <> LCase(strContactName) Then 'DebugOffCall DebugAppend(" The Configured Name For The Contact: " & strContactName, True, False) 'DebugOffCall DebugAppend(" Could Not Be Found In The Exchange Directory!", True, False) strContactName = "" Else 'DebugOffCall DebugAppend(" Found resource contact: " & _ 'DebugOff strContactName, False, False) End If ElseIf blnMemberFound = False Then 'DebugOffCall DebugAppend(" Contact is not defined", True, False) End If Set objContact = Nothing Set objAddressList = Nothing Set objDistList = Nothing 'If Not Restricting users of this resource set 'blnMemberFound to True to always accept requests. Else blnMemberFound = True End If If objMtg.Class <> CdoMeetingItem Then 'TraceOffg_blnTraceMsg = False strType = "Type - Not A Meeting Request" 'DebugOffCall DebugAppend(" Message is not a meeting request. Message Class: " & _ 'DebugOff objMtg.Class, True, False) 'Ok, It's a meeting, but is it a request ? ElseIf objMtg.MeetingType <> CdoMeetingRequest Then strType = "Type - Not A Meeting Request" 'DebugOffCall DebugAppend(" Meeting item is not a request. Meeting Type:" & _ 'DebugOff objMtg.MeetingType, True, False) 'For Schedule+ 1.0 Cancellations, the associated appointment 'does not exist, so we must check the type of the meeting 'request. ElseIf (objMtg.Type = "IPM.Schedule.Meeting.Canceled") And _ (objMtg.Sender.Type = "MS") Then Call DeleteOriginalAppt(objMtg.Fields(CdoPR_OWNER_APPT_ID).Value, _ objCdoSession.GetDefaultFolder(0)) Call SendCancelMsg(objCdoSession, objMtg) objMtg.Delete strType = "Type - Cancel Request" 'DebugOffCall DebugAppend(" Cancellation Request", True, False) Else objMtg.Unread = False objMtg.Update Set objAppt = objMtg.GetAssociatedAppointment If Err.Number = 0 Then 'GetAssociatedAppointment OK 'For users not found in Distribution Lists when restricting 'and request is not a cancellation. If blnMemberFound = False _ And objAppt.MeetingStatus <> CdoMeetingCanceled Then 'DebugOffCall DebugAppend(" Permission denied for user: " & _ 'DebugOff objMtg.Sender.Name, True, False) strType = "Type - Permission Denied" Set objMtgResp = objMtg.Respond(CdoResponseDeclined) objMtgResp.Subject = "Denied: " & objMtgResp.Subject objMtgResp.Text = "You do not have permission to schedule meetings with " & _ strUserName & " because you are not a member of the following Distribution Lists: " & _ strDistListNames & "." & vbCrLf & vbCrLf & "Meeting Request Declined." If strContactName <> "" Then objMtgResp.Text = objMtgResp.Text & vbCrLf & vbCrLf & _ "If you would like to request permission to " & _ "schedule meetings with this resource, please send " & _ "an email to the resource contact at <mailto:" & strContactName & _ "?Subject=" & strUserName & " Access Request. Distribution Lists: " & _ strDistListNames & ">" End If If objMtg.Sender.Type = "MS" Then Call MSFix(objMtgResp, objMtg) End If objMtgResp.ReadReceipt = False 'Take away sending an confirmation to Organizer of the meeting that the meeting was accepted 'objMtgResp.Send objMtg.Delete Set objAppt = Nothing ElseIf objAppt.MeetingStatus = CdoMeetingReceived Then If objAppt.IsRecurring = False _ Or objAppt.IsRecurring = True _ And blnAcceptRecur = True Then 'We only need to delete the associated appointment 'and the original appointment (if this is an update) 'if this request is from Schedule+ 1.0. If objMtg.Sender.Type = "MS" Then objAppt.Delete Call DeleteOriginalAppt( _ objMtg.Fields(CdoPR_OWNER_APPT_ID).Value, _ objCdoSession.GetDefaultFolder(0)) End If blnIsFree = False 'Set IsFree booleen variable to default of False If IsFree(objMtg, objAppt, objCdoSession.GetDefaultFolder(0), _ dtmConflict, strOrganizer, strType) Then blnIsFree = True 'Set IsFree booleen variable to true 'TraceOffstrAccepted = "Time: Free" 'DebugOffCall DebugAppend(" Free - Accepting meeting", True, False) Set objMtgResp = objMtg.Respond(CdoResponseAccepted) objMtgResp.Subject = "Accepted: " & objMtgResp.Subject Set objAppt = objMtgResp.GetAssociatedAppointment 'The previous call fails on Schedule+ Requests so check & clear if error. If Err = CdoE_TOO_COMPLEX Then Err.Clear End If objAppt.ReplyTime = Now() objAppt.Fields.Add CdoPR_OWNER_APPT_ID, _ objMtg.Fields(CdoPR_OWNER_APPT_ID).Value If blnNoReminders <> False Then objAppt.ReminderSet = False 'Sets reminders on for all accepted meetings Dim ReminderSetting ReminderSetting = Trim(objUser.Fields(PR_EMS_AB_EXTENSION_ATTRIBUTE_7)) if UCase(Left(ReminderSetting, 11)) = "NO REMINDER" then objAppt.ReminderSet = False Else objAppt.ReminderSet = True objAppt.ReminderMinutesBeforeStart = 15 end if If blnSetAllAsBusy <> False Then objAppt.BusyStatus = CdoBusy If blnPrefixSubject Then objAppt.Subject = strSenderName & ": " & _ objAppt.Subject objAppt.Update Set objAppt = Nothing objMtgResp.Text = _ strUserName & " is available for the requested time." & _ vbCrLf & vbCrLf & _ "Meeting Request Accepted." Else Set objMtgResp = objMtg.Respond(CdoResponseDeclined) objMtgResp.Subject = "Declined: " & objMtgResp.Subject 'TraceOffstrAccepted = "Time: Busy" 'Set text of response message. If objAppt.IsRecurring = False _ Or strType = "Type - Single Instance Of Recurring Request" Then If strOrganizer <> "" Then strOrganizer = " due to a conflict with a meeting organized by " & _ strOrganizer & " <mailto:" & strOrganizer & ">" Else strOrganizer = "." End If objMtgResp.Text = _ strUserName & " is unavailable for the requested time" & _ strOrganizer & vbCrLf & vbCrLf & _ "Please use the 'Attendee Availability' tab and the " & _ "'Show Attendee Availability' button in the top left " & _ "hand corner of the tab to verify that this resource is " & _ "not already scheduled prior to sending meeting requests. " & _ vbCrLf & vbCrLf & _ "To reserve this resource for a previously " & _ "scheduled time or a new time please update " & _ "your meeting request again and make sure that " & _ "the time scheduled is available." & vbCrLf & vbCrLf & _ "Meeting Request Declined." 'DebugOffCall DebugAppend(" Conflict found - Declining meeting", _ 'DebugOff True, False) End If If objAppt.IsRecurring _ And strType = "Type - Single Instance f Recurring Request" Then objAppt.Delete ElseIf objAppt.IsRecurring _ And strType = "Type - Recurring Request Greater Than Maximum Allowed" Then 'TraceOffstrAccepted = "" objMtgResp.Text = strUserName & " does not accept recurring " & _ "meeting requests that have occurrences beyond " & _ g_intMaxRecur & " months from today. Please " & _ "update the meeting by:" & vbCrLf & vbCrLf & _ "Opening it in your calendar." & vbCrLf & _ "Click the 'Recurrence' button on the toolbar." & vbCrLf & _ "Specify an 'End by' date of no later than " & _ DateAdd("m", g_intMaxRecur, Date) & "." & vbCrLf & _ "Click 'OK' to close the 'Appointment Recurrence' dialog box." & vbCrLf & _ "Click 'Send Update' on the toolbar." & vbCrLf & vbCrLf & _ "Meeting Request Declined." ElseIf objAppt.IsRecurring Then If strOrganizer <> "" Then strOrganizer = " and the conflicting meeting was organized by: " & _ strOrganizer & " <mailto:" & strOrganizer & ">" End If objMtgResp.Text = _ strUserName & " is unavailable for at least one instance " & _ "of your recurring meeting request and no instances of " & _ "this request have been accepted. The first conflict " & _ "found is on " & dtmConflict & strOrganizer & _ vbCrLf & vbCrLf & _ "Meeting Request Declined." 'DebugOffCall DebugAppend(" Conflict found on " & dtmConflict & _ 'DebugOff " - Declining meeting", True, False) End If End If Else strType = "Type - Declined: Recurring meeting - not permitted" Set objMtgResp = objMtg.Respond(CdoResponseDeclined) objMtgResp.Subject = "Declined: " & objMtgResp.Subject objMtgResp.Text = _ strUserName & " does not accept Recurring Meeting Requests." & _ vbCrLf & vbCrLf & _ "Please send individual requests for each meeting " & _ "you would like to schedule." & vbCrLf & vbCrLf 'DebugOffCall DebugAppend(" Recurring Meeting Requests are not allowed " & _ 'DebugOff " by this Resource - declining meeting request", _ 'DebugOff True, False) End If If objMtg.Sender.Type = "MS" Then Call MSFix(objMtgResp, objMtg) End If Set objAppt = Nothing objMtgResp.ReadReceipt = False 'Want to change Recipient to the Person Accepting the Meeting here 'Comment out the command below will take away sending a confirmation to Organizer of the meeting that the meeting was accepted objMtgResp.Send objMtg.UnRead = True objMtg.Update '*********************************************** '* Confirmation feature - Send a confirmation message to the meeting recipent '************************************************** If blnIsFree = True Then Call SendNewEventMsg(objCdoSession, objMtg) End If '************************************************** '* End of Confirmation feature '************************************************** objMtg.Delete ElseIf objAppt.MeetingStatus = CdoMeetingCanceled Then strType = "Type - Cancel Request" 'DebugOffCall DebugAppend(" Cancellation Request", True, False) Call SendCancelMsg(objCdoSession, objMtg) objAppt.Delete objMtg.Delete End If Else 'GetAssociatedAppointment Failed. 'If the meeting is a cancellation and the associated 'appointment is not in the calendar, then just delete 'the cancellation notice. If (objMtg.Type = "IPM.Schedule.Meeting.Canceled") Then strType = "Type - Cancel Request No Match" 'DebugOffCall DebugAppend(" Cancellation Request - not in calendar", True, False) Err.Clear Call SendCancelMsg(objCdoSession, objMtg) objMtg.Delete End If End If 'Err.Number = 0 End If 'Check for any possible sys errors 'DebugOffCall DebugAppend("Error Detected: ", True, True) 'TraceOffIf g_blnTraceMsg = True Then 'TraceOff Call TraceOutput(objCdoSession, objUser, strSenderName, strType, strAccepted) 'TraceOffEnd If 'DebugOffCall DebugAppend(":End - Folder_OnMessageCreated " & Time, True, False) Script.Response = vbCrLf & g_sDiagLog End Sub ' PRIVATE FUNCTIONS/SUBS '-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-' '-----------------------------------------------------------------' ' Name: DebugAppend ' Desc: Simple Debugging Function ' Parm: String Text, Bool ErrorFlag '-----------------------------------------------------------------' 'DebugOffPrivate Sub DebugAppend(bstrParm, blnDiagLog, blnErrChkFlag) 'DebugOff 'DebugOff If blnErrChkFlag = True Then 'DebugOff If Err.Number <> 0 Then 'DebugOff 'DebugOff 'TraceOffIf g_blnTraceMsg = True Then 'DebugOff 'TraceOff g_sTraceMsg = g_sTraceMsg & bstrParm & "-" & _ 'DebugOff 'TraceOff CStr(Err.Number) & Err.Description & vbCrLf 'DebugOff 'TraceOffEnd If 'DebugOff 'DebugOff g_sDiagLog = g_sDiagLog & bstrParm & "-" & _ 'DebugOff CStr(Err.Number) & Err.Description & vbCrLf 'DebugOff 'DebugOff Err.Clear 'DebugOff 'DebugOff End If 'DebugOff 'DebugOff Else 'DebugOff 'TraceOffIf g_blnTraceMsg = True Then 'DebugOff 'TraceOff 'DebugOff 'TraceOff g_sTraceMsg = g_sTraceMsg & bstrParm & vbCrLf 'DebugOff 'TraceOff 'DebugOff 'TraceOffEnd If 'DebugOff 'DebugOff If blnDiagLog = True Then 'DebugOff 'DebugOff g_sDiagLog = g_sDiagLog & bstrParm & vbCrLf 'DebugOff 'DebugOff End If 'DebugOff 'DebugOff End If 'DebugOff 'DebugOffEnd Sub '-----------------------------------------------------------------' ' Name: DeleteOriginalAppt ' Desc: Schedule+ 1.0 Mtg Request Update Handling ' Parm: Integer PR_OWNER_APPT_ID, Object CalendarFolder '-----------------------------------------------------------------' Private Sub DeleteOriginalAppt(strApptID, _ objCalendar) Dim colMsgs 'Messages collection Dim objAppt 'Appointment Dim objField Set objField = Nothing Set colMsgs = objCalendar.Messages For Each objAppt In colMsgs On Error Resume Next Set objField = objAppt.Fields(CdoPR_OWNER_APPT_ID) If Not objField Is Nothing Then If objField.Value = strApptID Then objAppt.Delete 'Delete appt Exit For End If End If Set objField = Nothing Next Set objAppt = Nothing Set colMsgs = Nothing Set objCalendar = Nothing End Sub '-----------------------------------------------------------------' ' Name: FindConflicts ' Desc: Manually Check Free/Busy in Calendar ' Parm: Object CalendarFolder, Date & Time StartTime, ' Date & Time EndTime ' Retn: String Conflict Organizer's Name, Boolean Conflict Found '-----------------------------------------------------------------' Private Function FindConflicts(objCalendar, dtmStartTime, dtmEndTime, strOrganizer) Dim colMsgs 'Messages Collection Dim objMsgFilter 'Filter for Messages Collection Dim objAppt 'Appointment Dim strFreeBusy FindConflicts = CdoFree 'Default: Time is Free Set colMsgs = objCalendar.Messages Set objMsgFilter = colMsgs.Filter objMsgFilter.Fields.Add CdoPR_START_DATE, dtmEndTime objMsgFilter.Fields.Add CdoPR_END_DATE, dtmStartTime Set objAppt = colMsgs.GetFirst If objAppt Is Nothing Then 'No appointments met filter condition FindConflicts = CdoFree 'so time is free. Else Set objAppt = colMsgs.GetFirst Do While (Not objAppt Is Nothing) 'We'll ignore appointments that start when ours ends 'or that end when ours starts. If Not ((CDate(objAppt.StartTime) = CDate(dtmEndTime)) _ Or (CDate(objAppt.EndTime) = CDate(dtmStartTime))) Then 'Make sure the appointment is not "free" 'Ver 05If (Not objAppt.BusyStatus = CdoFree) Then If objAppt.BusyStatus > CdoTentative Then FindConflicts = CdoBusy On Error Resume Next strOrganizer = CStr(objAppt.Organizer.Name) If Err = CdoE_NO_SUPPORT Then Err.Clear Exit Do End If End If Set objAppt = colMsgs.GetNext Loop End If 'Now we do a completely separate check for appointments that 'start in the middle of a recurring appointment instance. Set colMsgs = objCalendar.Messages Set objMsgFilter = colMsgs.Filter objMsgFilter.Fields.Add CdoPR_START_DATE, dtmEndTime Dim s_date s_date = CDate(dtmStartTime) objMsgFilter.Fields.Add CdoPR_END_DATE, DateSerial(Year(s_date), _ Month(s_date), Day(s_date) - 1) 'We have to go back far enough to catch all instances of 'appointments that last long enough that they could extend 'to the start of our requested time period. '24 hrs seems like a reasonable period for this (based on 'the assumption that no one will have an room booked for 'more than 24 hours) Set objAppt = colMsgs.GetFirst If objAppt Is Nothing Then 'No appointments met filter condition FindConflicts = CdoFree 'so time is free. Else Do While (Not objAppt Is Nothing) 'Ignore appointments that start when ours ends or end when 'ours starts. If (Not (CDate(objAppt.StartTime) = CDate(dtmEndTime) Or _ CDate(objAppt.EndTime) = CDate(dtmStartTime))) Then 'Attempt at additional checks to catch cases where our 'required time period starts during an instance of a 'recurring appointment. 'Have to use CDate to get date comparisons to work correctly. If (CDate(objAppt.StartTime) <= CDate(dtmStartTime)) _ And (CDate(objAppt.EndTime) >= CDate(dtmStartTime)) Then 'Ver 05If (Not (objAppt.BusyStatus = CdoFree)) Then If objAppt.BusyStatus > CdoTentative Then FindConflicts = CdoBusy On Error Resume Next strOrganizer = objAppt.Organizer.Name If Err = CdoE_NO_SUPPORT Then Err.Clear Exit Do End If End If End If Set objAppt = colMsgs.GetNext Loop End If If FindConflicts = 0 Then strFreeBusy = "Free" Else strFreeBusy = "Busy" End If 'DebugOffCall DebugAppend(" FindConflicts: " & dtmStartTime & " thru " & _ 'DebugOff dtmEndTime & " is " & strFreeBusy, _ 'DebugOff True, False) End Function '-----------------------------------------------------------------' ' Name: IsFree ' Desc: Checks the user's calendar for conflicts ' Returns True if no conflicts were found otherwise False. ' Handles recurring meetings ' Parm: AdrressEntry object, AppointmentItem object, Folder object, ' String ConflictingAppt, String Request Type '-----------------------------------------------------------------' Private Function IsFree(objMtg, objAppt, objCalendar, dtmConflict, strOrganizer, strType) On Error Resume Next Dim lngMinutes 'Number of minutes in appointment Dim intReturnBusyStatus 'Returned BusyStatus Dim objRecurrencePattern 'RecurrencePattern object Dim dtmFirstStartTime 'Start date/time of first ever occurrence Dim dtmCurrentStartTime 'Current Start date/time Dim dtmCurrentEndTime 'Current End date/time Dim intApptBusyStatus 'BusyStatus used for single instance of recurring appt.s Dim dtmMaxRecur IsFree = True 'Default result = success 'DebugOffCall DebugAppend(": Start - IsFree " & Time, True, False) dtmCurrentStartTime = objAppt.StartTime If objAppt.IsRecurring = False Then 'Normal, one-off meeting. strType = "Type - Normal Request" 'DebugOffCall DebugAppend(" Meeting is a one-time request", True, False) intReturnBusyStatus = FindConflicts(objCalendar, objAppt.StartTime, objAppt.EndTime, strOrganizer) If intReturnBusyStatus <> CdoFree Then IsFree = False End If ElseIf objAppt.IsRecurring And Err = 0 Then 'Single Instance of a Recurring Appointment. strType = "Type - Single Instance Of Recurring Request" 'DebugOffCall DebugAppend(" Meeting is a single instance of a recurring request", _ 'DebugOff True, False) dtmCurrentStartTime = objAppt.StartTime dtmCurrentEndTime = objAppt.EndTime intApptBusyStatus = objAppt.BusyStatus 'Get the Appt's BusyStatus objAppt.BusyStatus = CdoFree 'Set it to Free so it won't conflict objAppt.Update 'Ver 06intReturnBusyStatus = FindConflicts(objCalendar, dtmCurrentStartTime, dtmCurrentEndTime, strOrganizer) intReturnBusyStatus = CdoFree 'Ver 06 If intReturnBusyStatus <> CdoFree Then IsFree = False End If objAppt.BusyStatus = intApptBusyStatus 'Set the Appt's BusyStatus to original setting objAppt.Update ElseIf objAppt.IsRecurring And Err = CdoE_NO_SUPPORT Then Err.Clear 'DebugOffCall DebugAppend(" Meeting is recurring", True, False) 'Recurring meeting, get RecurrencePattern object for meeting Set objRecurrencePattern = objAppt.GetRecurrencePattern() If g_intMaxRecur > 0 Then dtmMaxRecur = DateAdd("m", g_intMaxRecur, Date) If DateDiff("d", dtmMaxRecur, objRecurrencePattern.PatternEndDate) > 0 _ Or objRecurrencePattern.PatternEndDate = "" Then IsFree = False strType = "Type - Recurring Request Greater Than Maximum Allowed" 'DebugOffCall DebugAppend(" Recurring Request End Date: " & _ 'DebugOff objRecurrencePattern.PatternEndDate, True, False) 'DebugOffCall DebugAppend(" extends beyond the maximum of " & _ 'DebugOff g_intMaxRecur & " months from today", True, False) 'DebugOffCall DebugAppend(": End - IsFree " & Time, True, False) Exit Function End If End If strType = "Type - Recurring Request" 'Start time dtmCurrentStartTime = objRecurrencePattern.StartTime dtmFirstStartTime = dtmCurrentStartTime 'Calculate the total number of minutes in the appointment. lngMinutes = DateDiff("n", dtmCurrentStartTime, objRecurrencePattern.EndTime) 'Loop until a busy slot is found or all recurrences are free. Do 'Recalculate End Time dtmCurrentEndTime = DateAdd("n", lngMinutes, dtmCurrentStartTime) 'Check free/busy status. 'Ver 06intReturnBusyStatus = FindConflicts(objCalendar, dtmCurrentStartTime, dtmCurrentEndTime, strOrganizer) intReturnBusyStatus = CdoFree 'Ver 06** 'No point continuing if slot is busy. If intReturnBusyStatus <> CdoFree Then dtmConflict = FormatDateTime(dtmCurrentStartTime, vbShortDate) IsFree = False Exit Do End If 'Calculate the next recurrence Start time based on recurrence 'type. Select Case objRecurrencePattern.RecurrenceType Case CdoRecurTypeDaily 'Add interval days. dtmCurrentStartTime = DateAdd("d", objRecurrencePattern.Interval, dtmCurrentStartTime) Case CdoRecurTypeMonthly 'Add interval months. dtmCurrentStartTime = DateAdd("m", objRecurrencePattern.Interval, dtmCurrentStartTime) Case CdoRecurTypeYearly 'Add interval years. dtmCurrentStartTime = DateAdd("m", 12 * objRecurrencePattern.Interval, dtmCurrentStartTime) Case CdoRecurTypeMonthlyNth 'Add interval months then find next instance in the month. dtmCurrentStartTime = DateAdd("m", objRecurrencePattern.Interval, dtmCurrentStartTime) Call FindInstanceInMonth(dtmFirstStartTime, objRecurrencePattern.Instance, _ dtmCurrentStartTime) Case CdoRecurTypeYearlyNth 'Add interval years then find next instance in month. dtmCurrentStartTime = DateAdd("m", 12 * objRecurrencePattern.Interval, dtmCurrentStartTime) Call FindInstanceInMonth(dtmFirstStartTime, objRecurrencePattern.Instance, _ dtmCurrentStartTime) Case CdoRecurTypeWeekly 'Find the next recurrence this week. Call FindInstanceInWeek(objRecurrencePattern.DayOfWeekMask, _ objRecurrencePattern.Interval, dtmCurrentStartTime) Case Else 'DebugOffCall DebugAppend(" Recurrence Type did not match list: " & _ 'DebugOff objRecurrencePattern.RecurrenceType, True, False) End Select 'Limit number of recurrences checked for yearly meetings and 'daily/weekly/monthly meetings. If (objRecurrencePattern.RecurrenceType = CdoRecurTypeYearlyNth) Or _ (objRecurrencePattern.RecurrenceType = CdoRecurTypeYearly) Then If DateDiff("m", dtmFirstStartTime, dtmCurrentStartTime) > MaxYearlyRecur Then Exit Do End If ElseIf (objRecurrencePattern.RecurrenceType = CdoRecurTypeMonthlyNth) Or _ (objRecurrencePattern.RecurrenceType = CdoRecurTypeMonthly) Then If DateDiff("m", dtmFirstStartTime, dtmCurrentStartTime) > MaxMonthlyRecur Then Exit Do End If ElseIf (objRecurrencePattern.RecurrenceType = CdoRecurTypeWeekly) Then If DateDiff("m", dtmFirstStartTime, dtmCurrentStartTime) > MaxWeeklyRecur Then Exit Do End If Else If DateDiff("m", dtmFirstStartTime, dtmCurrentStartTime) > MaxDailyRecur Then Exit Do End If End If Loop While (dtmCurrentEndTime <= objRecurrencePattern.PatternEndDate) Else 'Could not detect the type of request! strType = "Type - Error Unknown" 'DebugOffCall DebugAppend(" Could not detect type of request!", True, False) 'DebugOffCall DebugAppend("Error Detected: ", True, True) IsFree = False End If 'DebugOffCall DebugAppend(": End - IsFree " & Time, True, False) End Function '-----------------------------------------------------------------' ' Name: FindInstanceInMonth ' Desc: Returns the start date/time of the next meeting in the ' current month ' Parm: Date & Time First StartTime, Long DayOfMonth, ' Date & Time Current StartTime ' Retn: Date & Time next StartTime '-----------------------------------------------------------------' Private Sub FindInstanceInMonth(dtmFirstStartTime, lngDayOfMonth, dtmCurrentStartTime) Dim LastWeek 'Start from the beginning of the month. dtmCurrentStartTime = DateAdd("d", (0 - Day(dtmCurrentStartTime)) + 1, dtmCurrentStartTime) 'Find the first day of recurrence (Monday) in the month. 'If the beginning of the month falls after the day of recurrence 'we use next week's instance. If Weekday(dtmFirstStartTime) < Weekday(dtmCurrentStartTime) Then dtmCurrentStartTime = DateAdd("d", (7 - Weekday(dtmCurrentStartTime)) + Weekday(dtmFirstStartTime), dtmCurrentStartTime) Else dtmCurrentStartTime = DateAdd("d", Weekday(dtmFirstStartTime) - Weekday(dtmCurrentStartTime), dtmCurrentStartTime) End If 'If the meeting is scheduled for the last week of a period, then 'we look for a 5th instance (albeit clumsily). If (lngDayOfMonth = 5) Then 'If 4 weeks from hence we're still in the same month then we 'have 5th instance, otherwise the last week is the 4th instance. LastWeek = DateAdd("d", 28, dtmCurrentStartTime) If Month(LastWeek) <> Month(dtmCurrentStartTime) Then dtmCurrentStartTime = DateAdd("d", 21, dtmCurrentStartTime) Else dtmCurrentStartTime = LastWeek End If ElseIf (lngDayOfMonth > 1) Then 'Go to specific instance. dtmCurrentStartTime = DateAdd("d", (lngDayOfMonth - 1) * 7, dtmCurrentStartTime) End If End Sub '-----------------------------------------------------------------' ' Name: FindInstanceInWeek ' Desc: Returns the start date/time for the next meeting in the ' current week ' Parm: Long DayOfWeekMask, Long IntervalOfAppt. ' Date & Time Current StartTime ' Retn: Date & Time next StartTime '-----------------------------------------------------------------' Private Sub FindInstanceInWeek(lngDayOfWeekMask, _ lngInterval, _ dtmCurrentStartTime) 'Iterate through each day of the week until matching day is found. Do 'If the meetings are scheduled at > 1 week intervals and we've 'reached the end of the current week, we skip to the next 'interval. If (Weekday(dtmCurrentStartTime) = 7) And (lngInterval > 1) Then dtmCurrentStartTime = DateAdd("d", (lngInterval - 1) * 7, dtmCurrentStartTime) End If Loop While GetNextDayOfWeek(lngDayOfWeekMask, dtmCurrentStartTime) <> True End Sub '-----------------------------------------------------------------' ' Name: GetNextDayOfWeek ' Desc: Returns the start date/time of the next meeting matching ' the DayOfWeek mask for the current week ' Parm: Long DayOfWeekMask, Date & Time Current StartTime ' Retn: Date & Time next StartTime '-----------------------------------------------------------------' Private Function GetNextDayOfWeek(lngDayOfWeekMask, _ dtmCurrentStartTime) Dim i GetNextDayOfWeek = False 'Default result. 'Iterate through each day in the week until a match is found. 'in the DayOfWeek mask Do dtmCurrentStartTime = DateAdd("d", 1, dtmCurrentStartTime) i = 2 ^ (Weekday(dtmCurrentStartTime) - 1) If ((lngDayOfWeekMask And i) = i) Then GetNextDayOfWeek = True Exit Do End If Loop While Weekday(dtmCurrentStartTime) <> 7 End Function '-----------------------------------------------------------------' ' Name: SendCancelMsg ' Desc: Sends a Canccelation Confirmation message to the requestor ' Parm: Object Session, Object Meeting '-----------------------------------------------------------------' Private Function SendCancelMsg(objCdoSession, _ objMtg) Dim objOutbox Dim objMsgResp 'DebugOffCall DebugAppend(" Sending Cancel Message", False, False) Set objOutbox = objCdoSession.Outbox Set objMsgResp = objOutbox.Messages.Add objMsgResp.Type = "IPM.Note" objMsgResp.Text = CStr(objCdoSession.CurrentUser.Name) & _ " Meeting Cancellation Request Completed." & _ vbCrLf & vbCrLf & _ "Canceled Meeting Details" & vbCrLf & _ objMtg.Text objMsgResp.Subject = "Meeting: " & objMtg.Subject objMsgResp.ConversationTopic = objMtg.ConversationTopic objMsgResp.Recipients.Add objCdoSession.CurrentUser.Name objMsgResp.Recipients.Resolve False objMsgResp.Update objMsgResp.Send Set objMsgResp = Nothing Set objOutbox = Nothing End Function '**************************************************** '* Confirmation feature - Send a confirmation message to the meeting recipent '************************************************** '-----------------------------------------------------------------' ' Name: SendNewEventMsg ' Desc: Sends a New Event Confirmation message to the receiver ' Parm: Object Session, Object Meeting ' objMtg.StartTime '-----------------------------------------------------------------' Private Function SendNewEventMsg(objCdoSession, _ objMtg) On Error Resume Next Dim lngMinutes 'Number of minutes in appointment Dim intReturnBusyStatus 'Returned BusyStatus Dim objRecurrencePattern 'RecurrencePattern object Dim dtmFirstStartTime 'Start date/time of first ever occurrence Dim dtmCurrentStartTime 'Current Start date/time Dim dtmCurrentEndTime 'Current End date/time Dim intApptBusyStatus 'BusyStatus used for single instance of recurring appt.s Dim dtmMaxRecur Dim objAttachColl Dim I Dim ObjAtt Dim fso Dim strFile Dim objOutbox Dim objMsgConfirm Dim objAppointment Set objOutbox = objCdoSession.Outbox Set objMsgConfirm = objOutbox.Messages.Add Set objAppointment = objMtg.GetAssociatedAppointment '***************** Dim MyRecips for each Recips in objAppointment.Recipients myRecips = myRecips & " " & Recips.Name & "," i = i + 1 if i > 100 then exit for end if next 'myRecips = Left(myRecips, Len(myRecips - 1)) '***************** 'objMsgConfirm.Class = "IPM.Note" objMsgConfirm.Type = "IPM.Note" '************************** '************************** '************************** '************************** '************************** '************************** '************************** '************************** '************************** '************************** If objAppointment.IsRecurring = False Then 'Normal, one-off meeting. strType = "Type - Normal Request" 'DebugOffCall DebugAppend(" Meeting is a one-time request", True, False) dtmCurrentStartTime = objAppointment.StartTime dtmCurrentEndTime = objAppointment.EndTime ElseIf objAppointment.IsRecurring And Err = 0 Then 'Single Instance of a Recurring Appointment. strType = "Type - Single Instance Of Recurring Request" 'DebugOffCall DebugAppend(" Meeting is a single instance of a recurring request", _ 'DebugOff True, False) dtmCurrentStartTime = objAppointment.StartTime dtmCurrentEndTime = objAppointment.EndTime intApptBusyStatus = objAppointment.BusyStatus 'Get the Appt's BusyStatus objAppointment.BusyStatus = CdoFree 'Set it to Free so it won't conflict objAppointment.Update 'Ver 06intReturnBusyStatus = FindConflicts(objCalendar, dtmCurrentStartTime, dtmCurrentEndTime, strOrganizer) intReturnBusyStatus = CdoFree 'Ver 06 If intReturnBusyStatus <> CdoFree Then IsFree = False End If objAppointment.BusyStatus = intApptBusyStatus 'Set the Appt's BusyStatus to original setting objAppointment.Update ElseIf objAppointment.IsRecurring And Err = CdoE_NO_SUPPORT Then Err.Clear 'DebugOffCall DebugAppend(" Meeting is recurring", True, False) dtmCurrentStartTime = "Error1" 'Recurring meeting, get RecurrencePattern object for meeting Set objRecurrencePattern = objAppointment.GetRecurrencePattern() 'If g_intMaxRecur > 0 Then ' dtmMaxRecur = DateAdd("m", g_intMaxRecur, Date) ' If DateDiff("d", dtmMaxRecur, objRecurrencePattern.PatternEndDate) > 0 _ ' Or objRecurrencePattern.PatternEndDate = "" Then ' IsFree = False ' strType = "Type - Recurring Request Greater Than Maximum Allowed" ' 'DebugOffCall DebugAppend(" Recurring Request End Date: " & _ ' 'DebugOff objRecurrencePattern.PatternEndDate, True, False) ' 'DebugOffCall DebugAppend(" extends beyond the maximum of " & _ ' 'DebugOff g_intMaxRecur & " months from today", True, False) ' 'DebugOffCall DebugAppend(": End - IsFree " & Time, True, False) ' Exit Function ' End If 'End If dtmCurrentStartTime = "Error2" strType = "Type - Recurring Request" 'Start time dtmCurrentStartTime = objRecurrencePattern.StartTime dtmFirstStartTime = dtmCurrentStartTime dtmCurrentStartTime = "Error3" 'Calculate the total number of minutes in the appointment. lngMinutes = DateDiff("n", dtmCurrentStartTime, objRecurrencePattern.EndTime) dtmCurrentStartTime = "Error4" 'Loop until a busy slot is found or all recurrences are free. Do 'Recalculate End Time dtmCurrentEndTime = DateAdd("n", lngMinutes, dtmCurrentStartTime) 'Check free/busy status. 'Ver 06intReturnBusyStatus = FindConflicts(objCalendar, dtmCurrentStartTime, dtmCurrentEndTime, strOrganizer) 'intReturnBusyStatus = CdoFree 'Ver 06** 'No point continuing if slot is busy. 'If intReturnBusyStatus <> CdoFree Then ' dtmConflict = FormatDateTime(dtmCurrentStartTime, vbShortDate) ' IsFree = False ' Exit Do 'End If 'Calculate the next recurrence Start time based on recurrence 'type. Select Case objRecurrencePattern.RecurrenceType Case CdoRecurTypeDaily 'Add interval days. 'dtmCurrentStartTime = DateAdd("d", objRecurrencePattern.Interval, dtmCurrentStartTime) Case CdoRecurTypeMonthly 'Add interval months. 'dtmCurrentStartTime = DateAdd("m", objRecurrencePattern.Interval, dtmCurrentStartTime) Case CdoRecurTypeYearly 'Add interval years. 'dtmCurrentStartTime = DateAdd("m", 12 * objRecurrencePattern.Interval, dtmCurrentStartTime) Case CdoRecurTypeMonthlyNth 'Add interval months then find next instance in the month. 'dtmCurrentStartTime = DateAdd("m", objRecurrencePattern.Interval, dtmCurrentStartTime) 'Call FindInstanceInMonth(dtmFirstStartTime, objRecurrencePattern.Instance, _ ' dtmCurrentStartTime) Case CdoRecurTypeYearlyNth 'Add interval years then find next instance in month. 'dtmCurrentStartTime = DateAdd("m", 12 * objRecurrencePattern.Interval, dtmCurrentStartTime) 'Call FindInstanceInMonth(dtmFirstStartTime, objRecurrencePattern.Instance, _ ' dtmCurrentStartTime) Case CdoRecurTypeWeekly 'Find the next recurrence this week. 'Call FindInstanceInWeek(objRecurrencePattern.DayOfWeekMask, _ ' objRecurrencePattern.Interval, dtmCurrentStartTime) Case Else 'DebugOffCall DebugAppend(" Recurrence Type did not match list: " & _ 'DebugOff objRecurrencePattern.RecurrenceType, True, False) End Select 'Limit number of recurrences checked for yearly meetings and 'daily/weekly/monthly meetings. 'If (objRecurrencePattern.RecurrenceType = CdoRecurTypeYearlyNth) Or _ ' (objRecurrencePattern.RecurrenceType = CdoRecurTypeYearly) Then ' If DateDiff("m", dtmFirstStartTime, dtmCurrentStartTime) > MaxYearlyRecur Then ' Exit Do ' End If 'ElseIf (objRecurrencePattern.RecurrenceType = CdoRecurTypeMonthlyNth) Or _ ' (objRecurrencePattern.RecurrenceType = CdoRecurTypeMonthly) Then ' If DateDiff("m", dtmFirstStartTime, dtmCurrentStartTime) > MaxMonthlyRecur Then ' Exit Do ' End If 'ElseIf (objRecurrencePattern.RecurrenceType = CdoRecurTypeWeekly) Then ' If DateDiff("m", dtmFirstStartTime, dtmCurrentStartTime) > MaxWeeklyRecur Then ' Exit Do ' End If 'Else ' If DateDiff("m", dtmFirstStartTime, dtmCurrentStartTime) > MaxDailyRecur Then ' Exit Do ' End If 'End If Loop While (dtmCurrentEndTime <= objRecurrencePattern.PatternEndDate) End if '**************************** '************************** '************************** '************************** '************************** '************************** '************************** '************************** '************************** '**************************** ' if objAppointment.IsRecurring Then Set objRecurrencePattern = objAppointment.GetRecurrencePattern() dtmCurrentStartTime = objRecurrencePattern.StartTime dtmCurrentEndTime = objRecurrencePattern.EndTime Dim dtmCurrent dtmCurrent = objRecurrencePattern.Interval 'Set dtmCurrent = objMtg.Item(CdoPropSetID1 & "0x8232") objMsgConfirm.Text = objMtg.Sender.Name & " has scheduled you for a meeting. " & _ vbCrLf & vbCrLf & "When: " & dtmCurrentStartTime & " to " & dtmCurrentEndTime & " Interval " & dtmCurrent & vbCrLf & "Where: " & ObjAppointment.Location & vbCrLf & "Attendees: " & _ myRecips & vbCrLf & vbCrLf & objAppointment.Text else objMsgConfirm.Text = objMtg.Sender.Name & " has scheduled you for a meeting. " & _ vbCrLf & vbCrLf & "When: " & objAppointment.StartTime & " to " & objAppointment.EndTime & vbCrLf & "Where: " & ObjAppointment.Location & vbCrLf & "Attendees: " & _ myRecips & vbCrLf & vbCrLf & objAppointment.Text end if 'objMsgConfirm.StartTime = objAppointment.StartTime 'objMsgConfirm.EndTime = objAppointment.EndTime 'objMsgConfirm.Text = objMsgConfirm.Text & "Click here to open the item... <outlook:\\Mailbox - Test Joel\Calendar\~" & objMtg.Subject & ">" objMsgConfirm.Text = objMsgConfirm.Text & vbCrLf & strBooleans objMsgConfirm.Sender = objMtg.Sender objMsgConfirm.Subject = "Meeting: " & objMtg.Subject objMsgConfirm.ConversationTopic = objMtg.ConversationTopic objMsgConfirm.Recipients.Add objCdoSession.CurrentUser.Name objMsgConfirm.Recipients.Resolve False objMsgConfirm.Update objMsgConfirm.Send '**************************** '************************** '************************** '************************** '************************** '************************** '************************** '************************** '************************** '************************** Set objMsgConfirm = Nothing Set objOutbox = Nothing Set objAppointment = Nothing End Function '************************************************** '* End of Confirmation feature '************************************************** '-----------------------------------------------------------------' ' Name: MSFix ' Desc: Fixes fields for Schedule+ compatibility ' Parm: Object Meeting Response, Object Meeting Request '-----------------------------------------------------------------' Private Function MSFix(objMtgResp, _ objMtg) 'Copy PR_OWNER_APPT_ID so that the response is 'registered when received by Schedule+ 1.0. objMtgResp.Fields(CdoPR_OWNER_APPT_ID).Value = _ objMtg.Fields(CdoPR_OWNER_APPT_ID).Value 'Copy PR_SENT_REPRESENTING... properties to 'PR_RCVD_REPRESENTING properties to prevent '"You are not this person's assistant". objMtgResp.Fields.Add CdoPR_RCVD_REPRESENTING_ENTRYID, _ objMtg.Fields(CdoPR_SENT_REPRESENTING_ENTRYID).Value objMtgResp.Fields.Add CdoPR_RCVD_REPRESENTING_NAME, _ objMtg.Fields(CdoPR_SENT_REPRESENTING_NAME).Value 'DebugOffCall DebugAppend("Error Detected: ", True, True) End Function '-----------------------------------------------------------------' ' Name: Trace_Output ' Desc: Posts a Trace Message to the TraceMsgs Folder ' Parm: Object Session, Object CurrentUser, String Sender's Name, ' String Request Type, String Free or Busy '-----------------------------------------------------------------' 'TraceOffPrivate Function TraceOutput(objCdoSession, objUser, strSenderName, strType, strAccepted) 'TraceOff Dim objCategories 'TraceOff Dim objTraceMsg 'TraceOff Dim colTraceMsgs 'TraceOff Dim blnSuccess 'Success or failure 'TraceOff 'TraceOff blnSuccess = SetMsgCollection(objCdoSession, "Calendar TraceMsgs", True, colTraceMsgs) 'TraceOff 'TraceOff If Not colTraceMsgs Is Nothing Then 'TraceOff Set objTraceMsg = colTraceMsgs.Add 'TraceOff 'TraceOff objTraceMsg.Type = "IPM.Post" 'TraceOff Set objTraceMsg.Sender = objUser 'TraceOff objTraceMsg.Sent = True 'TraceOff objTraceMsg.Submitted = False 'TraceOff objTraceMsg.Unread = True 'TraceOff objTraceMsg.TimeSent = Date & " " & Time 'TraceOff objTraceMsg.TimeReceived = Date & " " & Time 'TraceOff 'TraceOff If strAccepted <> "" Then 'TraceOff objCategories = Array(strType, strAccepted) 'TraceOff Else 'TraceOff objCategories = Array(strType) 'TraceOff End If 'TraceOff 'TraceOff objTraceMsg.Categories = objCategories 'whole array; no index or parameter 'TraceOff objTraceMsg.Subject = strSenderName 'TraceOff objTraceMsg.Text = g_sTraceMsg & ":End - Folder_OnMessageCreated " & Time 'TraceOff objTraceMsg.ConversationTopic = Date 'TraceOff objTraceMsg.Update 'TraceOff Else 'TraceOff Call DebugAppend("!TraceOutput - The Message Collection Object could " & _ 'TraceOff "not be set on the TraceMsgs folder!", True, True) 'TraceOff End If 'TraceOff 'TraceOff**End Function '-----------------------------------------------------------------' ' Name: SetMsgCollection ' Desc: Sets a Message Collection Object ' Parm: Object Session, String Sender's Name, String Folder Name, ' Boolean Add Folder ' Retn: Object Message Collection, Boolean Success or Failure '-----------------------------------------------------------------' Private Function SetMsgCollection(objCdoSession, strFldName, blnAddFld, colMsgs) Dim colStores 'Information stores collection Dim objStore 'Information store Dim colFolders 'Folders collection Dim objFolder 'Folder object Dim intLoop 'For Loop counter On Error Resume Next SetMsgCollection = True Set colMsgs = Nothing Set objFolder = Nothing Set colStores = objCdoSession.InfoStores For intLoop = 1 To colStores.Count Set objStore = colStores.Item(intLoop) If objStore.Name = "Mailbox - " & objCdoSession.CurrentUser.Name Then Set objStore = colStores.Item(intLoop) Exit For End If Next Set colFolders = objStore.RootFolder.Folders For Each objFolder In colFolders If objFolder.Name = strFldName Then Set colMsgs = objFolder.Messages Exit For End If Next If blnAddFld = True _ And colMsgs Is Nothing Then Set objFolder = colFolders.Add(strFldName) Set colMsgs = objFolder.Messages End If If Err Then Err.Clear SetMsgCollection = False End If End Function '-----------------------------------------------------------------' ' Name: CheckDList ' Desc: Looks for Sender of Message in supplied Distribution List ' If Distribution List contains nested DL's it will check each of them ' Parm: Object Distribution List, Object Meeting Request ' Retn: Boolean Member found '-----------------------------------------------------------------' Private Function CheckDList(objDistList, objMtg, ByRef blnMemberFound) Dim objMember 'Member of distribution list If objDistList.Members.Count > 0 Then For Each objMember In objDistList.Members If objMember.IsSameAs(objMtg.Sender) Then blnMemberFound = True Exit For ElseIf objMember.Fields(CdoPR_DISPLAY_TYPE) = 1 Then CheckDList objMember, objMtg, blnMemberFound If blnMemberFound Then Exit For End If End If Next End If Set objMember = Nothing End Function '-----------------------------------------------------------------' ' Name: IsDList ' Desc: Verifies that supplied string is a valid distribution list ' Parm: String Distribution List name,Address List Object ' Retn: Distribution List Object, Boolean is a Distribution List '-----------------------------------------------------------------' Private Function IsDList(strDistList, objAddressList, ByRef objDistList, ByRef blnDistList) Set objDistList = objAddressList.AddressEntries(strDistList) 'Check if Exchange Display Name equals query and 'Display Type equals distribution list If LCase(objDistList.Name) = LCase(strDistList) _ And objDistList.Fields(CdoPR_DISPLAY_TYPE) = CdoDistList Then blnDistList = True 'this is a distribution list. End If End Function '-----------------------------------------------------------------' ' Name: CreateArray ' Desc: Creates an array from a delimited string ' Parm: String delimited values, String delimeters ' Retn: Array values '-----------------------------------------------------------------' Private Function CreateArray(strValues, strSearch, aryValues) Dim strEntries Dim strEntry Dim intPos Dim intCounter strEntries = strValues intCounter = 0 If strEntries <> "" Then intPos = InStr(strEntries, strSearch) If intPos Then Do While Len(strEntries) If intPos Then strEntry = Left(strEntries, intPos - 1) strEntries = Mid(strEntries, intPos + Len(strSearch)) intPos = InStr(strEntries, strSearch) Else strEntry = strEntries strEntries = "" End If ReDim Preserve aryValues(intCounter) aryValues(intCounter) = strEntry intCounter = intCounter + 1 Loop Else ReDim aryValues(0) aryValues(0) = strEntries End If End If End Function </SCRIPT>
All 2comments

	Page [ 1 ]
	Joel Foudy 22-May-2003 13:20 Ok, Here's my problem. Right now the meeting response (objMtgResp object) sends a confirmation back to the Organizer of the meeting. I'd like to change this to go to the person who accepts the meeting instead, but I'm not sure how to code that. Any help such as sample code or a reference guide to help me would be great. Thanks! (To test and run this code add an Agent on a persons inbox that processes when new messages arrive. You must have and Exchange server to do this. If you don't have an Agents tab add the Server Scripting add-in for Outlook.)
	Norbert Nellen 02-Dec-2003 10:16 Hello Joel, I used the Ressource Scripting example from Microsoft to and I add some function in addition. I send an information to everyone who is invited by the Organizer. I create a Procedure SendInfoMailToRecipients (...) You can call this procedure by: SendInfoMailToRecipients EventDetails.Session, oMtg, "Buchung storniert: " & oMtg.Subject , "Termin: " & vbCrLf & oMtg.Subject & vbCrLf & oMtg.Text & vbCrLf & "Bitte loschen Sie diesen Termin aus Ihrem Kalender; Sie werden ggfs. erneut eingeladen." '---------------------------------------------------------------------' ' Name: SentNewMsg ( ... ) ' Zweck: Benachrichtigungsmail versenden ' ' Parm: oSession = Aktuelle Session ' strSubject = Betreff ' strMsg = Benachrichtigungstext der gesendet werden soll ' strTo = User an den gesendet werden soll (kann auch ein Verteiler sein) ' '---------------------------------------------------------------------' ' Sub SentNewMsg (oSession, strSubject,strMsg,strTo) 'Benachrichtigung erzeugen und Senden Dim oRecipient Dim oNotifyMsg Dim oFolderOutbox Err.Clear Set oFolderOutbox = oSession.Outbox Set oNotifyMsg = oFolderOutbox.Messages.Add If strSubject "" Then Else strSubject = Now End If If Err.Number = 0 Then oNotifyMsg.Subject = strSubject oNotifyMsg.Text = strMsg ' Set recipient Set oRecipient = oNotifyMsg.Recipients.Add oRecipient.Name = strTo oRecipient.Resolve If Err.Number 0 Then Call DebugAppend("Fehler - Empfanger konnte nicht aufgelost werden: " & strTo, True) Else ' Sent message oNotifyMsg.Update oNotifyMsg.Send If Err.Number 0 then Call DebugAppend("Fehler - Benachrichtigung konnte nicht gesendet werden.", True) Else Call DebugAppend("Erfolgreich - Nachricht wurde gesendet an: " & strTo, False) End If End If Else Call DebugAppend("Fehler - Es konnte keine Benachrichtigungsmeldung erzeugt werden.", True) End If End Sub '-----------------------------------------------------------------' ' Name: SendInfoMail ' Desc: Sendet eine Info-Mail an die eingeladeten Besprechungsteilnemer ' Parm: oMtg , strSubject , strInfo ' Retn: - '-----------------------------------------------------------------' Sub SendInfoMailToRecipients ( objSession, oMtg, strSubject, strInfo) Dim strEmpfaenger Dim Empfaenger Dim strHilf For EACH Empfaenger In oMtg.Recipients strEmpfaenger = UCase(Empfaenger.Address) strHilf = UCase ("EX:" & objSession.CurrentUser.Address) If strEmpfaenger strHilf Then SentNewMsg objSession, strSubject,strInfo,strEmpfaenger Call DebugAppend("SendInfoMail(): strHilf =" & strHilf & " strEmpfaenger = " & strEmpfaenger & " wurde INFO gesendet!" , FALSE) Else Call DebugAppend("SendInfoMail(): Empfanger:" & strEmpfaenger & " wurde ausgelassen!" , FALSE) End If Next End Sub I hope it is not to late to help you? Best Regards Norbert Nellen (MCP W2K) NNellen01@yahoo.de
	Page [ 1 ]

name email

Search Outlook Code