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 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 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.

Subscribe
Notify of
0 Comments
Inline Feedbacks
View all comments

Search for Word Macros

Recent Macros

VBA Macro used in the Microsoft Office Outlook Application

Outlook Send Same Email to Different Recipients | VBA Macro #31

To BCC or to not BCC?  That is the question that comes to mind when emailing a variety of different recipients.  This is especially important if you are working with multiple clients.  You can BCC recipients so they can’t click reply all. Recipients won’t see who was emailed but that is actually the problem.  The value is knowing who was emailed so customers know if additional follow-up is needed.  Instead you can CC recipients but once someone hits Reply All the conversation can get out of control.  This can create a bigger problem if the email thread is across multiple parties. Sending separate emails creates more value for the customer but how do you do this efficiently and effectively? You could create new emails do a lot of copying and pasting but this isn’t a sustainable process. Good news is there is always a better way with VBA! Our new Outlook macro makes sending the same email to different recipients so easy!

VBA Macro used in the Microsoft Office Excel Application

Excel Find and Replace across Multiple Word Documents | VBA Macro #30

Say a company rebranded and changed locations.  How would you handle updating all the necessary internal documents with the new company name, address, phone number, and email address? This can be a massive undertaking for any company which is why we created the Excel Find and Replace across Multiple Word Documents macro! This is an Excel macro that will Find and Replace values in Multiple Word Documents. This Excel macro is a great way to maintain Word Documents that are routinely changing information.

VBA Macro used in the Microsoft Office Word Application

Word Create Outlook Email with Selected Text | VBA Macro #29

Have you ever been prompted to send a follow up email while working in Word?  Maybe you are reviewing a meeting agenda or reading a final draft for a new company policy. You can navigate to Outlook create a new email and copy paste the necessary text in.  This takes a bit of time and isn’t very efficient.  Instead try using our Word Macro Create Outlook Email with Selected Text!  This macro will generate an Outlook email directly out of Word pulling in any text you have selected into the Email Body.  This macro is a better way to generate a follow up email helping you get a quicker response. Instead of writing reminders on Post-it notes start using this macro Create Outlook Email with Selected Text today!

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