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
The following code goes in an ordinary module. Change the recipients as appropriate.
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
I have prepared a
web page giving a little more detail that also features some minor but useful code changes.