VBA Macro used in the Microsoft Office Excel Application

Excel Calendar Reminder Macros

Share on facebook
Share on twitter
Share on linkedin

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!

Macro Instructions

Watch this video to get started using this macro.
Subscribe
Notify of
1 Comment
Oldest
Newest Most Voted
Inline Feedbacks
View all comments
trackback

[…] it easy to navigate through historical records. Take this macro to the next level and leverage the Excel Calendar Reminder Macros to schedule reoccurring actions on your Outlook Calendar. You can use the Open action to schedule […]

Search for Excel Macros

Recent Macros

VBA Macro used in the Microsoft Office Outlook Application

Outlook Greeting and Goodbye Contacts | VBA Macro #35

The Greeting and Goodbye Contact macro automates the entry of a Greeting “Good Morning” or “Hello” followed by the First Name of the recipient you are emailing. To identify the First Name this macro uses the recipient’s email address to loop through all the existing contact records for a matching email address. If a match is found the contact’s First Name field value is used in the beginning of the email. The appropriate Greeting and Goodbye is determined by the current time and the day of the week. The Greeting and Goodbye Contacts macro helps you deliver better customer service and create better connections with your clients!

VBA Macro used in the Microsoft Office Excel Application

Excel Custom Questionnaire to File | VBA Macro #34

This is an Excel macro that generates a custom questionnaire to complete.  The Role field is used to determine what questions display for specific users.  Once a user selects their Role, they can click Generate to see what questions they need to complete to finish the questionnaire.  After a user has completed all the required questions, they can click Finish to create a separate Excel Workbook with all the populated answers.   You can customize where this new file is saved making it easy to know when someone has completed a questionnaire and is awaiting review. There is also the option to send this separate Excel Workbook in an Outlook email with a couple updates to the VBA code. There is always a better way with VBA and this Excel macro helps standardize the collection of answers to specific questions. This can help lead to a more formal review process and eliminate mistakes.

VBA Macro used in the Microsoft Office Outlook Application

Outlook Hello Contacts | VBA Macro #33

Starting an email with a Hello can look more personable with some VBA code! The Hello Contacts Outlook macro automates the entry of the text Hello followed by the First Name of the recipient you are emailing. This Outlook macro uses the recipient’s email address to loop through all the existing contact records for a matching email address. If a match is found the contact’s First Name field value is used in the beginning of the email. This macro can be fired from a custom button or trigger automatically when replying to an email.

First time using VBA?

The Developer Tab is an additional section of the ribbon when activated allows you access to Visual Basic in Applications like Excel, Outlook, 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 needs to be set.
Setup Now

Looking for more?

Subscribe as an Insider to receive additional rights.

Contact Us

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

Copyright © 2019 Leverage & Lean – Uptown Style WordPress theme by GoDaddy