#1
|
|||
|
|||
reoccurring appointment that skips weekends
We schedule a meeting twice a month for the 15th and the last day of the month but if either of these dates falls on a weekend or holiday we back it up to the closest workday. is there a way that I can make a reoccurring event follow those rules? I saw some methods for making a list in excel and then importing it but I couldn't get it to work quite right.
|
#2
|
||||
|
||||
The short answer to your question is no, but it offered an intriguing prospect that would keep me amused for a while, so I have come up with a process that may work for you.
It works on the premise that you can process Outlook events, and in this case the start event. The idea is that every time you start Outlook, the start event runs and compares first day of the current month with an Excel worksheet log (attached) that has all the future dates (calculated in the worksheet to use only workdays) and looks in a column which indicates whether the month's meetings have been scheduled. This occurs very quickly, so you will not notice the interruption while the data is checked, usually needlessly. However the first time after the first of the month when you start Outlook, the log will indicate that the meetings have not been created, so the macro calls a process to create the meetings for that month and changes the log to indicate the meetings have been created. There are lots of message boxes in the code so you can monitor what is happening. You can remove these after testing as they are not required. Similarly remove the apostrophes from in front of the two '.Send lines after testing. You will only be able to run the process once a month without changing the 'processed' flag in the worksheet, or temporarily remove the code to save the worksheet. The following code goes in the ThisOutlookSession module. Change the path to reflect where you store the attached workbook. Code:
Option Explicit Private Sub Application_Startup() Const strWorkBook As String = "C:\Path\Meetings.xlsx" 'The workbook with the dates Const strSheet As String = "Sheet1" Dim objNS As Outlook.NameSpace Dim strDate As String Dim strDate1 As String Dim strDate2 As String Dim Arr() As Variant Dim iCols As Long Dim iRows As Long Set objNS = GetNamespace("MAPI") strDate = "01" & Format(Date, "/MM/YYYY") Arr = xlFillArray(strWorkBook, strSheet) For iRows = 0 To UBound(Arr, 2) If CDate(strDate) = Arr(0, iRows) Then If Arr(3, iRows) = True Then MsgBox "No meeting update required" GoTo lbl_Exit Else strDate1 = Arr(1, iRows) strDate2 = Arr(2, iRows) Call NewMeeting(CDate(strDate1), CDate(strDate2)) Call UpdateLog(strWorkBook, strSheet, strDate) End If End If Next iRows lbl_Exit: Exit Sub End Sub Private Function xlFillArray(strWorkBook As String, _ strWorksheetName As String) As Variant Dim RS As Object Dim CN As Object Dim iRows As Long strWorksheetName = strWorksheetName & "$]" Set CN = CreateObject("ADODB.Connection") CN.Open ConnectionString:="Provider=Microsoft.ACE.OLEDB.12.0;" & _ "Data Source=" & strWorkBook & ";" & _ "Extended Properties=""Excel 12.0 Xml;HDR=YES"";" Set RS = CreateObject("ADODB.Recordset") RS.Open "SELECT * FROM [" & strWorksheetName, CN, 2, 1 With RS .MoveLast iRows = .RecordCount .MoveFirst End With xlFillArray = RS.GetRows(iRows) If RS.State = 1 Then RS.Close Set RS = Nothing If CN.State = 1 Then CN.Close Set CN = Nothing lbl_Exit: Exit Function End Function Code:
Option Explicit Public Sub NewMeeting(Date1 As Date, Date2 As Date) Dim olMeeting1 As Object, olMeeting2 As Object Dim olRequiredAttendee As Recipient Dim olOptionalAttendee As Recipient Dim olResourceAttendee As Recipient Dim StartTime As Date Dim lngDuration As Long Const strLocation As String = "Conference Room" Const strSubject As String = "Strategy Meeting" Set olMeeting1 = Application.CreateItem(olAppointmentItem) StartTime = "09:00" lngDuration = 90 'minutes With olMeeting1 .MeetingStatus = olMeeting .Subject = strSubject .Location = strLocation .Start = Date1 & Chr(32) & StartTime .Duration = lngDuration 'Required attendees Set olRequiredAttendee = .Recipients.Add("Graham Mayor") olRequiredAttendee.Type = olRequired Set olRequiredAttendee = .Recipients.Add("Bill Bloggs") olRequiredAttendee.Type = olRequired 'Optional attendees 'Set olOptionalAttendee = .Recipients.Add("John Smith") 'olOptionalAttendee.Type = olOptional 'Resource attendees 'Set olResourceAttendee = .Recipients.Add("Fred Jones") 'olResourceAttendee.Type = olResource .Display '.sEnd 'restore after testing End With Set olMeeting2 = Application.CreateItem(olAppointmentItem) StartTime = "13:00" lngDuration = 120 'minutes With olMeeting2 .MeetingStatus = olMeeting .Subject = strSubject .Location = strLocation .Start = Date2 & Chr(32) & StartTime .Duration = lngDuration 'Required attendees Set olRequiredAttendee = .Recipients.Add("Graham Mayor") olRequiredAttendee.Type = olRequired Set olRequiredAttendee = .Recipients.Add("Bill Bloggs") olRequiredAttendee.Type = olRequired 'Optional attendees 'Set olOptionalAttendee = .Recipients.Add("John Smith") 'olOptionalAttendee.Type = olOptional 'Resource attendees 'Set olResourceAttendee = .Recipients.Add("Fred Jones") 'olResourceAttendee.Type = olResource .Display '.sEnd 'Restore after testing End With lbl_Exit: MsgBox "Meetings created" Exit Sub End Sub Public Sub UpdateLog(strWorkBook As String, strSheet As String, strDate As String) Dim xlApp As Object Dim xlWB As Object Dim xlRange As Object Dim xlCell As Object Dim bStarted As Boolean On Error Resume Next Set xlApp = GetObject(, "Excel.Application") If Err <> 0 Then Set xlApp = CreateObject("Excel.Application") bStarted = True End If On Error GoTo 0 Set xlWB = xlApp.Workbooks.Open(strWorkBook) With xlWB.Sheets(strSheet) Set xlCell = .Cells.Find(strDate) If Not xlCell Is Nothing Then If Not xlCell Is Nothing Then MsgBox "Log updated" xlCell.Offset(0, 3).Value = True Else MsgBox "Date not found" End If End If End With xlWB.Close SaveChanges:=True 'Remove while testing If bStarted Then xlApp.Quit Set xlApp = Nothing Set xlWB = Nothing End If lbl_Exit: Exit Sub End Sub
__________________
Graham Mayor - MS MVP (Word) (2002-2019) Visit my web site for more programming tips and ready made processes www.gmayor.com Last edited by gmayor; 04-10-2015 at 05:16 AM. |
Thread Tools | |
Display Modes | |
|
Similar Threads | ||||
Thread | Thread Starter | Forum | Replies | Last Post |
set daily goal for actual workdays, excluding weekends holidays and days off | Brian Reilly | Excel | 1 | 01-24-2014 11:56 PM |
Outlook 2003 - How to schedule Reoccurring Emails | techexpressinc | Outlook | 0 | 02-04-2011 02:51 PM |
Recurring tasks falling on weekends - programme for working day prior | guyc | Project | 3 | 09-26-2010 03:32 PM |
Skips too many lines: | stumptagen | Word | 0 | 03-24-2006 11:19 AM |
Needs option to delete foward only when deleting reoccurring | Peter Grono | Outlook | 1 | 02-19-2006 04:22 PM |