In our article discussing BCCing messages, Michael wanted to BCC all incoming meeting requests and cancellations to another address. You can do this with a run a script rule. The macro at the bottom of the page is an ItemAdd macro and watches for new items to be added to the calendar, forwarding appointment details as well as meeting details to another address.
The Run a script version is built off of the AutoAcceptMeeting request code sample.
To use this macro, open the VBA Editor (Alt+F11) and paste the code into ThisOutlookSession.
Next you will need to create a rule that looks for meeting cancellation or meeting request forms then choose the Run a Script action.
The macro creates and sends a message containing appointment details. The message body will look like the following screenshot and can be edited to add or remove fields.
Sub ForwardMeetingDetails(oRequest As MeetingItem) Dim oAppt As AppointmentItem Set oAppt = oRequest.GetAssociatedAppointment(True) Dim fwdAppt As MailItem Set fwdAppt = Application.CreateItem(olMailItem) strBody = "Organizer: " & oAppt.Organizer & vbCrLf _ & "Start: " & oAppt.Start & vbCrLf & "End: " & oAppt.End _ & vbCrLf & "Location: " & oAppt.Location & vbCrLf & "Message: " & oAppt.Body With fwdAppt .Recipients.Add "alias@domain.com" .Subject = oAppt.Subject .Body = strBody .Send End With End Sub
Forward appointment details when an appointment is added to the calendar
With a few tweaks to the macro above, you can forward all appointments added to your calendar to another address.
This macro watches for new items to be added to the calendar and sends the details in a message.
It's an Application_Startup procedure and runs when Outlook starts. To test it without restarting Outlook, click in the Application_Startup macro and press Run (F5).
This macro needs to be in ThisOutlookSession.
Dim WithEvents newAppt As Items
Private Sub Application_Startup()
Dim NS As Outlook.NameSpace
Set NS = Application.GetNamespace("MAPI")
Set newAppt = NS.GetDefaultFolder(olFolderCalendar).Items
Set NS = Nothing
End Sub
Private Sub newAppt_ItemAdd(ByVal Item As Object)
Dim fwdAppt As MailItem
Set fwdAppt = Application.CreateItem(olMailItem)
Dim strBody As String
strBody = "Organizer: " & Item.Organizer & vbCrLf _
& "Start: " & Item.Start & vbCrLf & "End: " & Item.End _
& vbCrLf & "Location: " & Item.Location & vbCrLf & "Message: " & Item.Body
With fwdAppt
.Recipients.Add "maryc@domain.net"
.Subject = Item.Subject
.BodyFormat = olFormatPlain
.Body = strBody
'Use Display to view onscreen and send yourself. Send will send it automatically
' .Display
.Send
End With
End Sub
More Information
More Run a Script Samples:
- Autoaccept a Meeting Request using Rules
- Automatically Add a Category to Accepted Meetings
- Blocking Mail From New Top-Level Domains
- Convert RTF Messages to Plain Text Format
- Create a rule to delete mail after a number of days
- Create a Task from an Email using a Rule
- Create an Outlook Appointment from a Message
- Create Appointment From Email Automatically
- Delegates, Meeting Requests, and Rules
- Delete attachments from messages
- Forward meeting details to another address
- How to Change the Font used for Outlook's RSS Feeds
- How to Process Mail After Business Hours
- Keep Canceled Meetings on Outlook's Calendar
- Macro to Print Outlook email attachments as they arrive
- Move messages CC'd to an address
- Open All Hyperlinks in an Outlook Email Message
- Outlook AutoReplies: One Script, Many Responses
- Outlook's Rules and Alerts: Run a Script
- Process messages received on a day of the week
- Read Outlook Messages using Plain Text
- Receive a Reminder When a Message Doesn't Arrive?
- Run a script rule: Autoreply using a template
- Run a script rule: Reply to a message
- Run a Script Rule: Send a New Message when a Message Arrives
- Run Rules Now using a Macro
- Run-a-Script Rules Missing in Outlook
- Save all incoming messages to the hard drive
- Save and Rename Outlook Email Attachments
- Save Attachments to the Hard Drive
- Save Outlook Email as a PDF
- Sort messages by Sender domain
- Talking Reminders
- To create a rule with wildcards
- Use a Macro to Copy Data in an Email to Excel
- Use a Rule to delete older messages as new ones arrive
- Use a run a script rule to mark messages read
- Use VBA to move messages with attachments
Hello Diane,
The script does not work when I test it by sending a meetingrequest to myself.
What could be the problem? Privacy-options?
its not privacy options -it picks up the values from the meeting request and creates an new message. If you send it to your own address, it could be a spam filter blocking mail from you, to you.
Try changing .send to .display so you can see the created message.
I have vba code in Outlook to forward an email if instr(subject line) = . Works great and thank you. The email address is actually a cell phone number as a SMS text. Works great, as long as Outlook is open.
If I close Outlook app, it does not work.
Before the VBA code, I did the email forwarding by setting up 'Manage Rules & Alerts | New Rule | Send an alert to my mobile device when I get messages from someone" When I set up this rule in this fashion, it DOES work when Outlook app is closed!
I would rather use the VBA method, as I need 60 people to set up their Outlook similarly
Is there a way to make the VBA scripts to run when Outlook is closed?
No, sorry, there is not. VBA need Outlook loaded to run.
Hi Daine,
I work in India, IST Time zone and our work hours are 9:00am-6:30pm.
Now since we work with USA clients, many meetings are scheduled after 7:00PM IST, to attend which either we have to connected via GTM from our mobile at the time of meeting or stretch our work hours to attend the meeting. So we need to prepare before hand for such meeting. But many a times we forget to check our calendar before we leave for the day and also these meetings we get a reminder 15/30 minutes prior to the start time of the meeting, which is after we have left from office. Hence we don't get notified at a correct time. So i wanted to know if there is an option to run a script at 6:00PM IST(as we are actively working in front of our desktop at that time), that reads from our calendar, meeting details, and displays as a pop up/ alert/ reminder, about the meetings that are scheduled after 6:30PM IST.
it should be possible - i don't have any scripts that do that, but will look into it as I'm sure others would like to do this too.
Great Diane,
Thank you for your quick response.
Hi Diane,
If you could help me with how to trigger any alert at the end of the day, i might be able to work on rest of the code to tag it with timing of the meeting and performing the filter.
Awaiting your response and thank you in advance for the help.
you need to use find or restrict to find the appointments that are scheduled after the appointed time and list them in a message box. You can kick this macro off manually or using a task reminder.
Why for me does not show the meeting status ? To work in Outlook 2016, I do that. Dim WithEvents newAppt As Items Sub ForwardMeetingDetails(oRequest As MeetingItem) Dim oAppt As AppointmentItem Set oAppt = oRequest.GetAssociatedAppointment(True) Dim fwdAppt As MailItem Set fwdAppt = Application.CreateItem(olMailItem) strBody = "Organizer: " & oAppt.Organizer & vbCrLf _ & "Start: " & oAppt.Start & vbCrLf & "End: " & oAppt.End _ & vbCrLf & "Location: " & oAppt.Location & vbCrLf & "Message: " & oAppt.Body With fwdAppt .Recipients.Add "mateus.mattos@sistemainfo.com.br" .Subject = oAppt.Subject .Body = strBody .Send End With End Sub Private Sub Application_Startup() Dim NS As Outlook.NameSpace Set NS = Application.GetNamespace("MAPI") Set newAppt = NS.GetDefaultFolder(olFolderCalendar).Items Set NS = Nothing MsgBox "Welcome, " & Application.GetNamespace("MAPI").CurrentUser 'Application.ActiveExplorer.WindowState = olMaximized End Sub Sub newAppt_ItemAdd(ByVal Item As Object) Dim fwdAppt As MailItem Set fwdAppt = Application.CreateItem(olMailItem) Dim strBody As String strBody = "Organizer: " & Item.Organizer & vbCrLf _ & "Start: " & Item.Start & vbCrLf & "End: " & Item.End _ & vbCrLf & "Location: " & Item.Location & vbCrLf & "Message: " & Item.Body With fwdAppt .Recipients.Add "mateus.mattos@sistemainfo.com.br" .Subject = Item.Subject .BodyFormat = olFormatPlain .Body = strBody 'Use Display to view onscreen and send yourself. Send will send… Read more »
What status do you want to include? You need to add that field to the string that is added to the body.
Hi Diane,
is there any option how to forward meeting request to personal email with no information to organizer?
Try attaching it to an email and don't accept it, just drag it off the message and into the calendar. Or use a macro to create an appointment with the details that is forwarded to your personal account.
Hi Diane, Sorry for the very late reply but this didn't work at all. I tried to delete the srs file in case it was corrupt but nothing. I did write this however from another code on the web, it works for me but can't seem to get it to work for other users! Any help would be appreciated. Ideally the first code would be better as its an automatic process. Thanks in advance! 'This is the email you want to forward meeting items to Private Const forwardMeetingsTo As String = "nev_evans@hotmail.com" 'This is the prefix in the subject for forwarded meeting appointments Private Const forwardSubjectPrefix As String = "[CalSync] " Private Sub Application_ItemSend(ByVal item As Object, Cancel As Boolean) ' Call to forward AppointmentItems on to a different address. The called method is responsible for determening the type of Item and for cleaning it before sending it on Call ForwardmeetingRequests(item) End Sub 'This method is called from the SendItem event, and will start the clean-and-forward 'procedure for Meeting requests Private Sub ForwardmeetingRequests(ByVal item As Object) Dim ic, bIsDuplicateAppointmentItem As Boolean Dim prop bIsDuplicateAppointmentItem = False ''''Start check to see if Item is a meeting. If so, make a call… Read more »
What happens when they try it? It worked fine here. If nothing happens, check their macro security.
This is the code that I've written based on your code. Thanks in advance
Dim WithEvents newAppt As Items
Sub Application_Startup()
Dim NS As Outlook.NameSpace
Set NS = Application.GetNamespace("MAPI")
Set newAppt = NS.GetDefaultFolder(olFolderCalendar).Items
Set NS = Nothing
End Sub
Error
Sub newAppt_ItemAdd(ByVal Item As Object)
Dim fwdAppt As AppointmentItem
Set fwdAppt = Application.CreateItem(olAppointmentItem)
With fwdAppt
.MeetingStatus = olMeeting
.Recipients.Add "alwynw27@gmail.com"
.Subject = "Copy" & Item.Subject
.Start = Item.Start
.Duration = Item.Duration
.Location = Item.Location
.Sensitivity = olPrivate
'Use Display to view onscreen and send yourself. Send will send it automatically .display .send'
.Display
End With
Set fwdAppt = Nothing
Try this one:
I've come up something and it does do what it's told, however it repeats the action as each time a new appointment is added to the calendar it send another appointment - I've had a total of 156 appointments being sent before I figured it out. Currently I've changed from .send to .display to get around this. Is there another way?
Or is it possible to forward all new appointments to gmail without it also displaying on my calendar for a second time?
I'll have to test it, but one option is moving the copy to a second calendar folder. Deleting it in code after sending it might work too.