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!
