VBA Macro used in the Microsoft Office Outlook Application

Outlook Calendar Reminder Macros

Share on facebook
Share on twitter
Share on linkedin

This is an Outlook macro designed to trigger actions from your Outlook Calendar. Simply schedule an appointment with the “Outlook” category. This macro will 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 within Outlook to run. 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.

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 Outlook 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, MacroName 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, ":"))
MacroName = "Outlook " & Action & " Calendar Reminder Macro"
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, ":"))
MacroName = "Excel " & Action & " Calendar Reminder Macro"
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, ":"))
MacroName = "Word " & Action & " Calendar Reminder Macro"
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

Call AddMacroCollection(MacroName)

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 OutlookPath As String 'Outlook
Dim ScheduledMacro As New ScheduledMacros 'Outlook

'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
objMsg.Display
'objMsg.Send
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

Macro Instructions

Watch this video to get started using this macro.

Insider Comments

  Subscribe  
Notify of

Search for Macros here!

Recent Macros

VBA Macro used in the Microsoft Office Outlook Application

Greeting and Goodbye

We are busy, sometimes too busy to type a friendly Greeting and Goodbye in our emails. This Outlook macro automates the entry of a Greeting “Good Morning” or “Hello” at the beginning of your emails. At the end of your email this macro automatically enters a Goodbye “Have a good night!” and “Enjoy your weekend!”. The Greeting and Goodbye macro helps you deliver better customer service and create better connections with your clients!

VBA Macro used in the Microsoft Office Outlook Application

Save Email as Outlook Email Template

It is DONE! You have drafted the perfect email and are prepared to send it. In the back of your mind you know that once you click Send it could be lost forever. Sure, you can try to copy the email to another folder or keep the email in your drafts but this isn’t sustainable in the long run. This is why Leverage & Lean created the Save Email as Outlook Template macro. With one click you can save your masterpiece and build toward your future!

VBA Macro used in the Microsoft Office Excel Application

Copy Multiple Excel Workbooks into One

This is an Excel Macro to copy separate workbooks into one MASTER workbook. The Details tab will serve as a guide for this macro seeing if you only want specific workbooks to be combined or all that exist in the folder. Additionally, you can indicate if you want only the first tab from each workbook to be copied or all of them. This Excel Macro makes it easy to pull multiple sources of information into one MASTER source on a routine basis.

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