This is an Outlook macro designed to trigger Excel actions from your Outlook Calendar. Simply schedule an appointment with the “Excel” category. This macro will then review the appointment subject field to determine what action to complete. Then based on the values in the other appointment fields proceed accordingly. The desired action will fire when the appointment reminder is triggered. You can also reoccur the appointment for routine actions to apply in the future!
Call:
This action will call a macro in an Excel Workbook to run. Enter the full path in the appointment Location field to indicate which workbook to open. In the appointment Subject field enter “Call:” any text after “:” will be considered the name of the macro to run. Watch this video to see this macro in action.
Create:
This action will create a new Excel Workbook and save it to the path identified in the Location field of the appointment. In the appointment Subject field enter “Create:” any text after “:” will be consider the name of the Excel Workbook created. Watch this video to see this macro in action.
Open:
This action will open any path or URL that you indicate in the location section. In the appointment Subject field enter “Open:” any text after “:” will not be utilized in this action. Watch this video to see this macro in action.
Send:
This action will send an email to the recipient identified in the Location field of the appointment. In the appointment Subject field enter “Send:” any text after “:” will be considered the subject of the email. Details in the appointment body will apply to the email body. Watch this video to see this macro in action.
The Code
Here is the code for the Excel Calendar Reminder Macros or start using all of the Calendar Reminder Macros with the link below.'Leverage & Lean "Less Clicks, More Results" Option Explicit 'Means variable is in use Private WithEvents oExpl As Explorer ' Private WithEvents oItem As MailItem ' Dim bDiscardEvents As Boolean ' Dim oResponse As MailItem ' Private Declare Function ShellExecute _ Lib "shell32.dll" Alias "ShellExecuteA" ( _ ByVal hWnd As Long, _ ByVal Operation As String, _ ByVal Filename As String, _ Optional ByVal Parameters As String, _ Optional ByVal Directory As String, _ Optional ByVal WindowStyle As Long = vbMinimizedFocus) As Long Public Sub Application_Reminder(ByVal Item As Object) ' Means variable is in use Dim Action, Macro As String 'All Dim SubjectLen As Integer 'All Dim Attachments As Object 'All Dim PathSuccess As Long 'All Dim objMsg As MailItem 'All Dim ExcelTitle, ExcelPath As String 'Excel Dim objExcel, ExcelWorkbook, Wb As Object 'Excel Dim OutlookPath As String 'Outlook Dim ScheduledMacro As New ScheduledMacros 'Outlook Dim objWord, WordDocument, doc As Object 'Word Dim WordTitle, WordPath As String 'Word Dim xlApp As Object 'Excel & Word Dim fso As Object 'Excel & Word Dim bStarted As Boolean 'Excel & Word Dim ToPos, PathPos As Integer 'Excel & Word Dim ToLocation, PathLocation As String 'Excel & Word 'Watch Appointment Calendar Reminders If Item.MessageClass = "IPM.Appointment" Then 'Process the Outlook Category macros If Item.Categories = "Outlook" Then Action = Left(Item.Subject, InStr(Item.Subject, ":")) If InStr(1, Action, "Call") = 1 Then 'Run Outlook Call Macro SubjectLen = Len(Item.Subject) - Len(Action) Macro = LTrim(RTrim(Right(Item.Subject, SubjectLen))) CallByName ScheduledMacro, Macro, VbMethod ElseIf InStr(1, Action, "Open") = 1 Then 'Run Outlook Open Macro OutlookPath = Item.Location PathSuccess = ShellExecute(0, "Open", OutlookPath) ElseIf InStr(1, Action, "Send") = 1 Then 'Run Outlook Send Macro Set objMsg = Application.CreateItem(olMailItem) objMsg.To = Item.Location SubjectLen = Len(Item.Subject) - Len(Action) objMsg.Subject = LTrim(RTrim(Right(Item.Subject, SubjectLen))) objMsg.Body = Item.Body If Item.Attachments.Count > 0 Then Call CopyAtts(Item, objMsg) 'Call macro to copy attachments from appt to email End If If Item.BusyStatus = olFree Then objMsg.Send ElseIf Item.BusyStatus <> olFree Then objMsg.Display End If End If End If 'Process the Excel Category macros If Item.Categories = "Excel" Then Action = Left(Item.Subject, InStr(Item.Subject, ":")) If InStr(1, Action, "Call") = 1 Then 'Run Excel Call Macro ExcelPath = Item.Location Set fso = CreateObject("Scripting.FileSystemObject") If Not fso.FileExists(ExcelPath) Then MsgBox "The personal workbook is not at the indicated location" Exit Sub End If 'Ensure Excel Application is Open On Error Resume Next Set xlApp = GetObject(, "Excel.Application") bStarted = False If Err <> 0 Then Set xlApp = CreateObject("Excel.Application") bStarted = True End If 'Make Excel Application Visible If Item.BusyStatus = olFree Then xlApp.Visible = False ElseIf Item.BusyStatus <> olFree Then xlApp.Visible = True End If If bStarted = True Or bStarted = False Then xlApp.Workbooks.Open ExcelPath Set Wb = xlApp.ActiveWorkbook SubjectLen = Len(Item.Subject) - Len(Action) Macro = LTrim(RTrim(Right(Item.Subject, SubjectLen))) xlApp.Run (Macro) ElseIf InStr(1, Action, "Create") = 1 Then 'Run Excel Create Macro SubjectLen = Len(Item.Subject) - Len(Action) ExcelTitle = LTrim(RTrim(Right(Item.Subject, SubjectLen))) Set objExcel = CreateObject("Excel.Application") Set ExcelWorkbook = objExcel.Workbooks.Add ExcelWorkbook.SaveAs Filename:="" & Item.Location & "\" & ExcelTitle & ".xlsx" 'Make Excel Application Visible If Item.BusyStatus = olFree Then objExcel.Visible = False ElseIf Item.BusyStatus <> olFree Then objExcel.Visible = True End If ElseIf InStr(1, Action, "Open") = 1 Then 'Run Excel Open Macro OutlookPath = Item.Location PathSuccess = ShellExecute(0, "Open", OutlookPath) ElseIf InStr(1, Action, "Send") = 1 Then 'Run Excel Send Macro ToPos = InStr(Item.Location, "To:") PathPos = InStr(Item.Location, "Path:") If ToPos < PathPos Then ToPos = ToPos + 2 ToLocation = Mid(Item.Location, ToPos + 1, PathPos - ToPos - 1) ToLocation = Replace(ToLocation, " ", "") PathPos = PathPos + 4 PathLocation = Right(Item.Location, Len(Item.Location) - PathPos) Do Until InStr(1, PathLocation, " ") > 1 PathLocation = Replace(PathLocation, " ", "", 1, 1) Loop ElseIf ToPos > PathPos Then PathPos = PathPos + 4 PathLocation = Mid(Item.Location, PathPos + 1, ToPos - PathPos - 1) Do Until InStr(1, PathLocation, " ") > 1 PathLocation = Replace(PathLocation, " ", "", 1, 1) Loop ToPos = ToPos + 2 ToLocation = Right(Item.Location, Len(Item.Location) - ToPos) ToLocation = Replace(ToLocation, " ", "") End If Set objMsg = Application.CreateItem(olMailItem) objMsg.To = ToLocation SubjectLen = Len(Item.Subject) - Len(Action) objMsg.Subject = LTrim(RTrim(Right(Item.Subject, SubjectLen))) objMsg.Body = Item.Body objMsg.Attachments.Add PathLocation If Item.BusyStatus = olFree Then objMsg.Send ElseIf Item.BusyStatus <> olFree Then objMsg.Display End If End If End If 'Process the Word Category macros If Item.Categories = "Word" Then Action = Left(Item.Subject, InStr(Item.Subject, ":")) If InStr(1, Action, "Call") = 1 Then 'Run Word Call Macro WordPath = Item.Location Set fso = CreateObject("Scripting.FileSystemObject") If Not fso.FileExists(WordPath) Then MsgBox "The personal document is not at the indicated location" Exit Sub End If 'Ensure Word Application is Open On Error Resume Next Set xlApp = GetObject(, "Word.Application") bStarted = False If Err <> 0 Then Set xlApp = CreateObject("Word.Application") bStarted = True End If 'Make Word Application Visible If Item.BusyStatus = olFree Then xlApp.Visible = False ElseIf Item.BusyStatus <> olFree Then xlApp.Visible = True End If If bStarted = True Or bStarted = False Then xlApp.Documents.Open WordPath Set doc = xlApp.ActiveDocument SubjectLen = Len(Item.Subject) - Len(Action) Macro = LTrim(RTrim(Right(Item.Subject, SubjectLen))) xlApp.Run (Macro) ElseIf InStr(1, Action, "Create") = 1 Then 'Run Word Create Macro SubjectLen = Len(Item.Subject) - Len(Action) WordTitle = LTrim(RTrim(Right(Item.Subject, SubjectLen))) Set objWord = CreateObject("Word.Application") Set WordDocument = objWord.Documents.Add WordDocument.SaveAs Filename:="" & Item.Location & "\" & WordTitle & ".docx" 'Make Word Application Visible If Item.BusyStatus = olFree Then objWord.Visible = False ElseIf Item.BusyStatus <> olFree Then objWord.Visible = True End If WordDocument.Activate WordDocument.Content.InsertAfter Item.Body WordDocument.Save ElseIf InStr(1, Action, "Open") = 1 Then 'Run Word Open Macro OutlookPath = Item.Location PathSuccess = ShellExecute(0, "Open", OutlookPath) ElseIf InStr(1, Action, "Send") = 1 Then 'Run Word Send Macro ToPos = InStr(Item.Location, "To:") PathPos = InStr(Item.Location, "Path:") If ToPos < PathPos Then ToPos = ToPos + 2 ToLocation = Mid(Item.Location, ToPos + 1, PathPos - ToPos - 1) ToLocation = Replace(ToLocation, " ", "") PathPos = PathPos + 4 PathLocation = Right(Item.Location, Len(Item.Location) - PathPos) Do Until InStr(1, PathLocation, " ") > 1 PathLocation = Replace(PathLocation, " ", "", 1, 1) Loop ElseIf ToPos > PathPos Then PathPos = PathPos + 4 PathLocation = Mid(Item.Location, PathPos + 1, ToPos - PathPos - 1) Do Until InStr(1, PathLocation, " ") > 1 PathLocation = Replace(PathLocation, " ", "", 1, 1) Loop ToPos = ToPos + 2 ToLocation = Right(Item.Location, Len(Item.Location) - ToPos) ToLocation = Replace(ToLocation, " ", "") End If Set objMsg = Application.CreateItem(olMailItem) objMsg.To = ToLocation SubjectLen = Len(Item.Subject) - Len(Action) objMsg.Subject = LTrim(RTrim(Right(Item.Subject, SubjectLen))) objMsg.Body = Item.Body objMsg.Attachments.Add PathLocation If Item.BusyStatus = olFree Then objMsg.Send ElseIf Item.BusyStatus <> olFree Then objMsg.Display End If End If End If End If End Sub Sub CopyAtts(Source, Target) Dim objFSO, fldTemp, strpath, strFile Dim objAtt, blnUseTempFile Const olByRefernce = 4 Const olByValue = 1 Const olEmbeddeditem = 5 Const TemporaryFolder = 2 Set objFSO = CreateObject("Scripting.FileSystemObject") Set fldTemp = objFSO.GetSpecialFolder(TemporaryFolder) strpath = fldTemp.Path & "\" For Each objAtt In Source.Attachments Select Case objAtt.Type Case olByReference strFile = objAtt.PathName blnUseTempFile = False Case olByValue, olEmbeddeditem strFile = strpath & objAtt.Filename objAtt.SaveAsFile strFile blnUseTempFile = True End Select If blnUseTempFile Then Target.Attachments.Add strFile, olByValue objFSO.DeleteFile strFile Else Target.Attachments.Add strFile, olByReference End If Next Set fldTemp = Nothing Set objFSO = Nothing End Sub 'Stay Awesome
'Leverage & Lean "Less Clicks, More Results" Option Explicit Private Declare Function ShellExecute _ Lib "shell32.dll" Alias "ShellExecuteA" ( _ ByVal hWnd As Long, _ ByVal Operation As String, _ ByVal Filename As String, _ Optional ByVal Parameters As String, _ Optional ByVal Directory As String, _ Optional ByVal WindowStyle As Long = vbMinimizedFocus) As Long Public Sub Application_Reminder(ByVal Item As Object) ' Means variable is in use Dim Action, Macro As String 'All Dim SubjectLen As Integer 'All Dim Attachments As Object 'All Dim PathSuccess As Long 'All Dim objMsg As MailItem 'All Dim ExcelTitle, ExcelPath As String 'Excel Dim objExcel, ExcelWorkbook, Wb As Object 'Excel Dim xlApp As Object 'Excel & Word Dim fso As Object 'Excel & Word Dim bStarted As Boolean 'Excel & Word Dim ToPos, PathPos As Integer 'Excel & Word Dim ToLocation, PathLocation As String 'Excel & Word 'Watch Appointment Calendar Reminders If Item.MessageClass = "IPM.Appointment" Then 'Process the Excel Category macros If Item.Categories = "Excel" Then Action = Left(Item.Subject, InStr(Item.Subject, ":")) If InStr(1, Action, "Call") = 1 Then 'Run Excel Call Macro ExcelPath = Item.Location Set fso = CreateObject("Scripting.FileSystemObject") If Not fso.FileExists(ExcelPath) Then MsgBox "The personal workbook is not at the indicated location" Exit Sub End If 'Ensure Excel Application is Open On Error Resume Next Set xlApp = GetObject(, "Excel.Application") bStarted = False If Err <> 0 Then Set xlApp = CreateObject("Excel.Application") bStarted = True End If 'Make Excel Application Visible xlApp.Visible = True If bStarted = True Or bStarted = False Then xlApp.Workbooks.Open ExcelPath Set Wb = xlApp.ActiveWorkbook SubjectLen = Len(Item.Subject) - Len(Action) Macro = LTrim(RTrim(Right(Item.Subject, SubjectLen))) xlApp.Run (Macro) ElseIf InStr(1, Action, "Create") = 1 Then 'Run Excel Create Macro SubjectLen = Len(Item.Subject) - Len(Action) ExcelTitle = LTrim(RTrim(Right(Item.Subject, SubjectLen))) Set objExcel = CreateObject("Excel.Application") Set ExcelWorkbook = objExcel.Workbooks.Add ExcelWorkbook.SaveAs Filename:="" & Item.Location & "\" & ExcelTitle & ".xlsx" 'Make Excel Application Visible objExcel.Visible = True ElseIf InStr(1, Action, "Open") = 1 Then 'Run Excel Open Macro ExcelPath = Item.Location PathSuccess = ShellExecute(0, "Open", ExcelPath) ElseIf InStr(1, Action, "Send") = 1 Then 'Run Excel Send Macro ToPos = InStr(Item.Location, "To:") PathPos = InStr(Item.Location, "Path:") If ToPos < PathPos Then ToPos = ToPos + 2 ToLocation = Mid(Item.Location, ToPos + 1, PathPos - ToPos - 1) ToLocation = Replace(ToLocation, " ", "") PathPos = PathPos + 4 PathLocation = Right(Item.Location, Len(Item.Location) - PathPos) Do Until InStr(1, PathLocation, " ") > 1 PathLocation = Replace(PathLocation, " ", "", 1, 1) Loop ElseIf ToPos > PathPos Then PathPos = PathPos + 4 PathLocation = Mid(Item.Location, PathPos + 1, ToPos - PathPos - 1) Do Until InStr(1, PathLocation, " ") > 1 PathLocation = Replace(PathLocation, " ", "", 1, 1) Loop ToPos = ToPos + 2 ToLocation = Right(Item.Location, Len(Item.Location) - ToPos) ToLocation = Replace(ToLocation, " ", "") End If Set objMsg = Application.CreateItem(olMailItem) objMsg.To = ToLocation SubjectLen = Len(Item.Subject) - Len(Action) objMsg.Subject = LTrim(RTrim(Right(Item.Subject, SubjectLen))) objMsg.Body = Item.Body objMsg.Attachments.Add PathLocation objMsg.Display 'objMsg.Send End If End If End If End Sub 'Stay Awesome!