VBA Macro used in the Microsoft Office Word Application

Word Calendar Reminder Macros

Share on facebook
Share on twitter
Share on linkedin

This is an Outlook macro designed to trigger Word actions from your Outlook Calendar. Simply schedule an appointment with the “Word” 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 a Word Document to run. Enter the full path in the appointment Location field to indicate which document 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 Word Document 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 Word Document 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 Word 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 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 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
xlApp.Visible = True
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
objWord.Visible = True
WordDocument.Activate
WordDocument.Content.InsertAfter Item.Body
WordDocument.Save
ElseIf InStr(1, Action, "Open") = 1 Then 'Run Word Open Macro
WordPath = Item.Location
PathSuccess = ShellExecute(0, "Open", WordPath)
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
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.

Insider Comments

  Subscribe  
Notify of

Search for Macros here!

Recent Macros

VBA Macro used in the Microsoft Office Excel Application

Copy Paste

This is an Excel macro that copies the contents of a worksheet one cell at a time allowing you to paste each value to a new destination. Once all the values in each column have been copied this macro continues onto the next row to do the same. This is extremely helpful for manual data entry as you can simply tab back to have the Copy Paste macro and move onto the next cell to copy. The Copy Paste macro helps you mistake proof your data entries avoiding any potential typos or populating the incorrect records.

VBA Macro used in the Microsoft Office Outlook Application

Move Old Emails

This Outlook macro makes cleaning out your inbox as easy as one click. The Move Old Emails macro will automatically move emails out of your inbox and into a different folder. No longer will you have to manually move old emails out of your inbox and make mistakes dragging emails to different folders. Spend more time in your inbox and get more done!

VBA Macro used in the Microsoft Office Excel Application

Excel Calendar Reminder Macros

This is an Outlook macro designed to trigger Excel actions from your Outlook Calendar. This macro will review appointments with the “Excel” category and based on the subject field determine what action to complete.

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