Calendar Reminder Macros

Welcome to the Calendar Reminder Macros page where you can learn all about Leverage & Lean’s Calendar Reminder Macros.

NEW & IMPROVED in 2021!

The Code

Here is the code for the Leverage & Lean Calendar Reminder Macros. Start using this VBA code to fire all the actions mentioned in the posts above!

'Leverage & Lean "Less Clicks, More Results"
Option Explicit
Private Declare PtrSafe 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 AccessDB As Access.Application 'Access
Dim Action As String, Body As String, DateFormat As String, Macros() As String, MacroTitle As String 'All
Dim cdataChild As MSXML2.IXMLDOMNode, newNode As MSXML2.IXMLDOMNode, pageNode As MSXML2.IXMLDOMNode, titleNode As MSXML2.IXMLDOMNode 'OneNote
Dim cd As MSXML2.IXMLDOMCDATASection 'OneNote
Dim FormLocation As String, Location As String, ToLocation As String, PathLocation As String  'All
Dim FormPos As Integer, l As Integer, ToPos As Integer, PathPos As Integer, u As Integer 'All
Dim fso As Object, objAttachment As Object, TempFolder As Object, xlApp As Object 'All
Dim Macro As Variant 'All
Dim newElement As MSXML2.IXMLDOMElement 'OneNote
Dim newPageID As String, outXML As String, sectionID As String 'OneNote
Dim objEmail As MailItem 'All
Dim OneNoteDoc As MSXML2.DOMDocument60 'OneNote
Dim OneNote As OneNote.Application 'OneNote
Dim PathSuccess As Long 'All
Dim PowerPoint As PowerPoint.Application
Dim ScheduledMacro As New ScheduledMacros 'Outlook

If Item.MessageClass = "IPM.Appointment" Then
'Set CRM Action Variables________________________________________________________________
Action = Left(Item.Subject, InStr(Item.Subject, ":")) 'Set Action
MacroTitle = LTrim(RTrim(Right(Item.Subject, Len(Item.Subject) - Len(Action)))) 'Set MacroTitle
If InStr(1, MacroTitle, "[Date]") > 0 Or InStr(1, MacroTitle, "[Date,") > 0 Then
l = InStr(1, MacroTitle, "[Date") + 5
u = InStr(1, MacroTitle, "]")
DateFormat = Mid(MacroTitle, l, u - l)
DateFormat = Replace(DateFormat, ",", "")
If DateFormat = "" Then
DateFormat = "mm.dd.yyyy"
End If
MacroTitle = Replace(MacroTitle, DateFormat, "")
MacroTitle = Replace(MacroTitle, "[Date]", Format(Date, DateFormat)) 'Set Dynamic Date if found in MacroTitle
MacroTitle = Replace(MacroTitle, "[Date,]", Format(Date, DateFormat)) 'Set Dynamic Date if found in MacroTitle
End If
Set fso = CreateObject("Scripting.FileSystemObject") 'Set fso
Location = Item.Location 'Set Location
If InStr(1, Location, "[Date]") > 0 Or InStr(1, Location, "[Date,") > 0 Then
l = InStr(1, Location, "[Date") + 5
u = InStr(1, Location, "]")
DateFormat = Mid(Location, l, u - l)
DateFormat = Replace(DateFormat, ",", "")
If DateFormat = "" Then
DateFormat = "mm.dd.yyyy"
End If
Location = Replace(Location, DateFormat, "")
Location = Replace(Location, "[Date]", Format(Date, DateFormat)) 'Set Dynamic Date if found in Location
Location = Replace(Location, "[Date,]", Format(Date, DateFormat)) 'Set Dynamic Date if found in Location
End If
FormPos = InStr(Location, "Form:")
ToPos = InStr(Location, "To:")
PathPos = InStr(Location, "Path:")
If FormPos > 0 And PathPos > 0 Then
Location = Replace(Location, "Form:", "")
Location = Replace(Location, "Path:", "")
If FormPos < PathPos Then
PathLocation = Right(Location, Len(Location) - PathPos + 5)
FormLocation = Left(Location, PathPos - 5)
ElseIf FormPos > PathPos Then
FormLocation = Right(Location, Len(Location) - FormPos + 5)
PathLocation = Left(Location, FormPos - 5)
End If
ElseIf ToPos > 0 And PathPos > 0 Then
Location = Replace(Location, "To:", "")
Location = Replace(Location, "Path:", "")
If ToPos < PathPos Then
PathLocation = Right(Location, Len(Location) - PathPos + 5)
ToLocation = Left(Location, PathPos - 5)
ElseIf ToPos > PathPos Then
ToLocation = Right(Location, Len(Location) - ToPos + 5)
PathLocation = Left(Location, ToPos - 5)
End If
End If
If FormLocation <> "" Then
Do Until InStr(1, FormLocation, " ") > 1
FormLocation = Replace(FormLocation, " ", "", 1, 1)
Loop
End If
If PathLocation <> "" Then
Do Until InStr(1, PathLocation, " ") > 1
PathLocation = Replace(PathLocation, " ", "", 1, 1)
Loop
End If
If ToLocation <> "" Then
Do Until InStr(1, ToLocation, " ") > 1
ToLocation = Replace(ToLocation, " ", "", 1, 1)
Loop
End If

'Open Action for all Category Values________________________________________________________
If InStr(1, Action, "Open") = 1 Then
PathSuccess = ShellExecute(0, "Open", Location)
'Copy Action for all Category Values________________________________________________________
ElseIf InStr(1, Action, "Copy") = 1 Then
If InStr(1, Action, "File") > 1 Then
If InStr(1, MacroTitle, "\") = 0 Then
fso.CopyFile Location, Left(Location, InStrRev(Location, "\")) & MacroTitle & "." & Right(Location, Len(Location) - InStrRev(Location, "."))
ElseIf InStr(1, MacroTitle, "\") > 0 Then
fso.CopyFile Location, MacroTitle & "." & Right(Location, Len(Location) - InStrRev(Location, "."))
End If
ElseIf InStr(1, Action, "Folder") > 1 Then
If InStr(1, MacroTitle, "\") = 0 Then
fso.CopyFolder Location, Left(Location, InStrRev(Location, "\")) & MacroTitle
ElseIf InStr(1, MacroTitle, "\") > 0 Then
fso.CopyFolder Location, MacroTitle
End If
End If
'Send Action for all Category Values (Except Outlook)_______________________________________
ElseIf InStr(1, Action, "Send") = 1 And Item.Categories <> "Outlook" Then
If Not fso.FileExists(PathLocation) Then
MsgBox "The " & Item.Categories & " file is not found at the path indicated in the Location field."
Exit Sub
End If
Set objEmail = Application.CreateItem(olMailItem)
objEmail.To = ToLocation
objEmail.Subject = MacroTitle
Body = Replace(Item.Body, "[Date]", Format(Date, "mm/dd/yyyy")) 'Set Dynamic Date if found in Body
objEmail.Body = Body
objEmail.Attachments.Add PathLocation
If Item.BusyStatus = olFree Then
objEmail.Send
ElseIf Item.BusyStatus <> olFree Then
objEmail.Display
End If
'Process the Access Category macros_______________________________________________________
ElseIf Item.Categories = "Access" Then
Set AccessDB = CreateObject("Access.Application")
If InStr(1, Action, "Call") = 1 Then 'Access Call Macro
If Not fso.FileExists(Location) Then
MsgBox "The " & Item.Categories & " file is not found at the path indicated in the Location field."
Exit Sub
End If
AccessDB.opencurrentdatabase Location, False
On Error Resume Next 'Ensure Access Application is Open
Set AccessDB = GetObject(, "Access.Application")
If Err <> 0 Then
Set AccessDB = CreateObject("Access.Application")
End If
MacroTitle = Replace(MacroTitle, " ", "")
Macros = Split(MacroTitle, ";")
For Each Macro In Macros
AccessDB.Run (Macro)
Next
ElseIf InStr(1, Action, "Query") = 1 Then 'Access Query Macro
If Not fso.FileExists(Location) Then
MsgBox "The " & Item.Categories & " file is not found at the path indicated in the Location field."
Exit Sub
End If
AccessDB.opencurrentdatabase Location, False
On Error Resume Next 'Ensure Access Application is Open
Set AccessDB = GetObject(, "Access.Application")
If Err <> 0 Then
Set AccessDB = CreateObject("Access.Application")
End If
MacroTitle = Replace(MacroTitle, " ", "")
Macros = Split(MacroTitle, ";")
For Each Macro In Macros
AccessDB.DoCmd.OpenQuery (Macro)
Next
ElseIf InStr(1, Action, "Start") = 1 Then 'Access Start Macro
If Not fso.FileExists(PathLocation) Then
MsgBox "The " & Item.Categories & " file is not found at the path indicated in the Location field."
Exit Sub
End If
AccessDB.opencurrentdatabase PathLocation, False
DoCmd.OpenForm FormLocation
Forms(FormLocation).Controls("End date") = Date
Forms(FormLocation).Controls("End time") = Now()
DoCmd.GoToRecord , , acNewRec
Forms(FormLocation).Controls("Project") = MacroTitle
Forms(FormLocation).Controls("Start date") = Date
Forms(FormLocation).Controls("Start time") = Now()
ElseIf InStr(1, Action, "Stop") = 1 Then 'Access Stop Macro
If Not fso.FileExists(PathLocation) Then
MsgBox "The " & Item.Categories & " file is not found at the path indicated in the Location field."
Exit Sub
End If
AccessDB.opencurrentdatabase PathLocation, False
DoCmd.OpenForm FormLocation
Forms(FormLocation).Controls("End date") = Date
Forms(FormLocation).Controls("End time") = Now()
End If
'Process the Excel Category macros________________________________________________________
ElseIf Item.Categories = "Excel" Then
Set xlApp = CreateObject("Excel.Application")
If Item.BusyStatus = olFree Then 'Set Excel Application Visibility
xlApp.Visible = False
ElseIf Item.BusyStatus <> olFree Then
xlApp.Visible = True
End If
If InStr(1, Action, "Call") = 1 Then 'Excel Call Macro
If Not fso.FileExists(Location) Then
MsgBox "The " & Item.Categories & " file is not found at the path indicated in the Location field."
Exit Sub
End If
On Error Resume Next 'Ensure Excel Application is Open
Set xlApp = GetObject(, "Excel.Application")
If Err <> 0 Then
Set xlApp = CreateObject("Excel.Application")
End If
xlApp.Workbooks.Open Location
MacroTitle = Replace(MacroTitle, " ", "")
Macros = Split(MacroTitle, ";")
For Each Macro In Macros
xlApp.Run (Macro)
Next
ElseIf InStr(1, Action, "Create") = 1 Then 'Excel Create Macro
xlApp.Workbooks.Add.SaveAs Filename:="" & Location & "\" & MacroTitle & ".xlsx"
End If
'Process the OneNote Category macros_____________________________________________________
ElseIf Item.Categories = "OneNote" Then
Set OneNote = New OneNote.Application 'Activate OneNote Application
If InStr(1, Action, "Call") = 1 Then 'OneNote Call Macro

ElseIf InStr(1, Action, "Create") = 1 Then 'OneNote Create Macro
OneNote.OpenHierarchy Location, "", sectionID
OneNote.CreateNewPage sectionID, newPageID, npsDefault
OneNote.GetPageContent newPageID, outXML, piAll, xs2013
Set OneNoteDoc = New MSXML2.DOMDocument60
If OneNoteDoc.LoadXML(outXML) Then
OneNoteDoc.SetProperty "SelectionNamespaces", "xmlns:one='http://schemas.microsoft.com/office/onenote/2013/onenote'"
Set pageNode = OneNoteDoc.SelectSingleNode("//one:Page")
Set titleNode = OneNoteDoc.SelectSingleNode("//one:Page/one:Title/one:OE/one:T")
Set cdataChild = titleNode.SelectSingleNode("text()")
cdataChild.Text = MacroTitle
OneNote.UpdatePageContent OneNoteDoc.XML
Set newElement = OneNoteDoc.createElement("one:Outline")
Set newNode = pageNode.appendChild(newElement)
Set newElement = OneNoteDoc.createElement("one:OEChildren")
Set newNode = newNode.appendChild(newElement)
Set newElement = OneNoteDoc.createElement("one:OE")
Set newNode = newNode.appendChild(newElement)
Set newElement = OneNoteDoc.createElement("one:T")
Set newNode = newNode.appendChild(newElement)
Body = Replace(Item.Body, "[Date]", Format(Date, "mm/dd/yyyy")) 'Set Dynamic Date if found in Body
Set cd = OneNoteDoc.createCDATASection(Body)
newNode.appendChild cd
OneNote.UpdatePageContent OneNoteDoc.XML
End If
End If
'Process the Outlook Category macros______________________________________________________
ElseIf Item.Categories = "Outlook" Then
If InStr(1, Action, "Call") = 1 Then 'Outlook Call Macro
MacroTitle = Replace(MacroTitle, " ", "")
Macros = Split(MacroTitle, ";")
For Each Macro In Macros
CallByName ScheduledMacro, Macro, VbMethod
Next
ElseIf InStr(1, Action, "Create") = 1 Then 'Outlook Create Macro
If fso.FolderExists(Location & "\" & MacroTitle) Then 'The Folder already exist
Else: fso.CreateFolder (Location & "\" & MacroTitle) 'The Folder has been created
End If
ElseIf InStr(1, Action, "Send") = 1 Then 'Outlook Send Macro
Set objEmail = Application.CreateItem(olMailItem)
objEmail.To = Location
objEmail.Subject = MacroTitle
Body = Replace(Item.Body, "[Date]", Format(Date, "mm/dd/yyyy")) 'Set Dynamic Date if found in Body
objEmail.Body = Body
If Item.Attachments.Count > 0 Then 'If Attachments Exist
Const olByValue = 1
Const olEmbeddeditem = 5
Const TemporaryFolder = 2
Set TempFolder = fso.GetSpecialFolder(TemporaryFolder)
For Each objAttachment In Item.Attachments
Select Case objAttachment.Type
Case olByValue, olEmbeddeditem
objAttachment.SaveAsFile TempFolder.Path & "\" & objAttachment.Filename 'Save the Attachment to the Temporary Folder
End Select
objEmail.Attachments.Add TempFolder.Path & "\" & objAttachment.Filename, olByValue 'Add Attachment to Email
fso.DeleteFile TempFolder.Path & "\" & objAttachment.Filename 'Delete the Attachment in the Temporary Folder
Next
End If
If Item.BusyStatus = olFree Then
objEmail.Send
ElseIf Item.BusyStatus <> olFree Then
objEmail.Display
End If
End If
'Process the PowerPoint Category macros___________________________________________________
ElseIf Item.Categories = "PowerPoint" Then
Set PowerPoint = CreateObject("PowerPoint.Application")
If InStr(1, Action, "Call") = 1 Then 'PowerPoint Call Macro
On Error Resume Next 'Ensure Word Application is Open
If Not fso.FileExists(Location) Then
MsgBox "The " & Item.Categories & " file is not found at the path indicated in the Location field."
Exit Sub
End If
Set PowerPoint = GetObject(, "PowerPoint.Application")
If Err <> 0 Then
Set PowerPoint = CreateObject("PowerPoint.Application")
End If
PowerPoint.Presentations.Open Location
MacroTitle = Replace(MacroTitle, " ", "")
Macros = Split(MacroTitle, ";")
For Each Macro In Macros
PowerPoint.Run (Macro)
Next
ElseIf InStr(1, Action, "Create") = 1 Then 'PowerPoint Create Macro
PowerPoint.Presentations.Add.SaveAs Filename:="" & Location & "\" & MacroTitle & ".pptx"
End If
'Process the Word Category macros________________________________________________________
ElseIf Item.Categories = "Word" Then
Set xlApp = CreateObject("Word.Application")
If Item.BusyStatus = olFree Then 'Set Word Application Visibility
xlApp.Visible = False
ElseIf Item.BusyStatus <> olFree Then
xlApp.Visible = True
End If
If InStr(1, Action, "Call") = 1 Then 'Word Call Macro
On Error Resume Next 'Ensure Word Application is Open
If Not fso.FileExists(Location) Then
MsgBox "The " & Item.Categories & " file is not found at the path indicated in the Location field."
Exit Sub
End If
Set xlApp = GetObject(, "Word.Application")
If Err <> 0 Then
Set xlApp = CreateObject("Word.Application")
End If
xlApp.Documents.Open Location
MacroTitle = Replace(MacroTitle, " ", "")
Macros = Split(MacroTitle, ";")
For Each Macro In Macros
xlApp.Run (Macro)
Next
ElseIf InStr(1, Action, "Create") = 1 Then 'Word Create Macro
xlApp.Documents.Add.SaveAs Filename:="" & Location & "\" & MacroTitle & ".docx"
xlApp.Activate
Body = Replace(Item.Body, "[Date]", Format(Date, "mm/dd/yyyy")) 'Set Dynamic Date if found in Body
xlApp.Content.InsertAfter Body
xlApp.Save
xlApp = ShellExecute(0, "Open", Location)
End If
End If
End If
 
End Sub
'Stay Awesome

First time using VBA?

Get started with these three easy steps!
The Developer Tab is an additional section of the ribbon when activated allows you access to Visual Basic in Applications like Access, Excel, Outlook, PowerPoint, Word.
Setup Now
Once the Developer Tab is available you will have the capability to update your security to allow Macros to run in the current application.
Setup Now
A sub of code is a collection of objects and variables. For the code to successfully run a library of references need to be set.
Setup Now

Contact Us

Looking to improve your computer processes?
Leverage & Lean is here to help!

Leverage & Lean

Is focused on improving computer processes by Leveraging programming and applying Lean principles. It is our goal to make you more efficient and effective on your computer producing “Less Clicks and More Results!”