In a discussion about the now-discontinued Getting Things Done Outlook addin in Outlook Forums, John had this comment:
Another function of GTDOA that I will really miss is being able to simultaneously reply to an email message, create a task or appointment, and have that email reply linked to the task or appointment. There is an obvious work-around for this - 1. send my email message, 2. go to my send directory and open it, 3. press "forward" or "reply" 4. CTRL+A to "copy all" of this email 5. close out 6. start a task/appoint and paste into it. *Whew* that is a lot of work! I question if there is an easy way to automate this process.
If you can use a macro, you can use a macro to automate it. I have a macro that comes close at "Automatically create a task when sending a message", but it doesn't add a link to the message. It adds the recipient addresses and the message body to the task, but HTML formatted messages will be copied to the task as text.
This macro gets the EntryID from the sent messages, copies the message body and pastes it into a new Task as formatted text, including the reply header and inserts a link to the original message.
If you prefer to create appointments instead of tasks, search and replace Task with Appointment.
This macro automatically runs when you send a message and needs to be in ThisOutlookSession.
If you want to create a task for every item you send, you can remove the prompt and message box lines.
Option Explicit Dim strID As String, strLink As String, strLinkText As String Private WithEvents olSentItems As Items Private Sub Application_Startup() Dim objNS As NameSpace Set objNS = Application.Session ' instantiate objects declared WithEvents Set olSentItems = objNS.GetDefaultFolder(olFolderSentMail).Items Set objNS = Nothing End Sub Private Sub olSentItems_ItemAdd(ByVal item As Object) On Error Resume Next Dim prompt As String Dim oForward As MailItem prompt$ = "Do you want to create a Task for this message?" If MsgBox(prompt$, vbYesNo + vbQuestion + vbMsgBoxSetForeground, "Create Task?") = vbYes Then strID = item.EntryID strLink = "outlook:" & strID strLinkText = item.Subject CreateTaskForMessage item End If End Sub Sub CreateTaskForMessage(item As MailItem) Dim objTask As Outlook.TaskItem Dim objInsp As Outlook.Inspector Dim oForward As MailItem ' Add reference to Word library ' in VBA Editor, Tools, References Dim objDoc As Word.Document Dim objWord As Word.Application Dim objSel As Word.Selection Dim oBookmark As Word.Bookmark Set oForward = item.Forward oForward.Display Set objInsp = oForward.GetInspector If objInsp.EditorType = olEditorWord Then Set objDoc = objInsp.WordEditor Set objWord = objDoc.Application 'removes your signature from the top of the Forward If objDoc.Bookmarks.Exists("_MailAutoSig") Then Set oBookmark = objDoc.Bookmarks("_MailAutoSig") oBookmark.Select objDoc.Windows(1).Selection.Delete End If Set objSel = objWord.Selection With objSel .WholeStory .Copy End With End If Set objTask = Application.CreateItem(olTaskItem) Set objInsp = objTask.GetInspector Set objDoc = objInsp.WordEditor Set objSel = objDoc.Windows(1).Selection With objTask .Subject = oForward.Subject objSel.PasteAndFormat (wdFormatOriginalFormatting) objSel.GoTo What:=wdGoToSection, Which:=wdGoToFirst objDoc.Hyperlinks.Add objSel.Range, strLink, "", "", strLinkText, "" objSel.Range.InsertBefore "Link to " .ReminderSet = True .ReminderTime = DateSerial(Year(Now), Month(Now), Day(Now + 2)) + #9:00:00 AM# .Display .Save End With oForward.Close olDiscard End Sub
Choose Task or Appointment
The macro above always creates a Task (or appointment if you change the item type). If you want to choose a task or appointment for each message, use this macro. It first asks if you want to create something, then you'll choose Task (Yes) or Appointment (No). Cancel exits the macro without creating a task or appointment.
The simple MsgBox dialog doesn't support changing Yes and No to other words. If you want the buttons labeled Task and Calendar, you need create a UserForm with buttons labeled Task and Calendar.
This macro automatically runs when you send a message and needs to be in ThisOutlookSession.
Option Explicit Dim strID As String, strLink As String, strLinkText As String Private WithEvents olSentItems As Items Private Sub Application_Startup() Dim objNS As NameSpace Set objNS = Application.Session ' instantiate objects declared WithEvents Set olSentItems = objNS.GetDefaultFolder(olFolderSentMail).Items Set objNS = Nothing End Sub Private Sub olSentItems_ItemAdd(ByVal Item As Object) On Error Resume Next Dim prompt As String Dim oForward As MailItem prompt$ = "Do you want to create a Task or Appointment for this message?" If MsgBox(prompt$, vbYesNo + vbQuestion + vbMsgBoxSetForeground, "Create Task or Appointment?") = vbYes Then strID = Item.EntryID strLink = "outlook:" & strID strLinkText = Item.Subject CreateTaskForMessage Item End If End Sub Sub CreateTaskForMessage(Item As MailItem) Dim prompt As String Dim objNewItem As Object Dim objInsp As Outlook.Inspector Dim oForward As MailItem ' Add reference to Word library ' in VBA Editor, Tools, References Dim objDoc As Word.Document Dim objWord As Word.Application Dim objSel As Word.Selection Dim oBookmark As Word.Bookmark Dim Response prompt$ = "Do you want to create a Task for this message?" & vbCrLf & "Choose Yes to create a Task." & vbCrLf & "Choose No to create an Appointment." Response = MsgBox(prompt$, vbYesNoCancel + vbQuestion + vbMsgBoxSetForeground, "Create Task or Appointment?") If Response = vbCancel Then Exit Sub Set oForward = Item.Forward oForward.Display Set objInsp = oForward.GetInspector If objInsp.EditorType = olEditorWord Then Set objDoc = objInsp.WordEditor Set objWord = objDoc.Application 'removes your signature from the top of the Forward If objDoc.Bookmarks.Exists("_MailAutoSig") Then Set oBookmark = objDoc.Bookmarks("_MailAutoSig") oBookmark.Select objDoc.Windows(1).Selection.Delete End If Set objSel = objWord.Selection With objSel .WholeStory .Copy End With End If oForward.Close olDiscard If Response = vbYes Then Set objNewItem = Application.CreateItem(olTaskItem) ' set task-only fields here With objNewItem .ReminderSet = True .ReminderTime = DateSerial(Year(Now), Month(Now), Day(Now + 2)) + #9:00:00 AM# End With Else Set objNewItem = Application.CreateItem(olAppointmentItem) 'set appointment-only fields here With objNewItem .Start = DateSerial(Year(Now), Month(Now), Day(Now + 2)) + #9:00:00 AM# End With End If Set objInsp = objNewItem.GetInspector Set objDoc = objInsp.WordEditor Set objSel = objDoc.Windows(1).Selection With objNewItem .Subject = strLinkText objSel.PasteAndFormat (wdFormatOriginalFormatting) objSel.GoTo What:=wdGoToSection, Which:=wdGoToFirst objDoc.Hyperlinks.Add objSel.Range, strLink, "", "", strLinkText, "" objSel.Range.InsertBefore "Link to " .Display .Save End With End Sub
Watch more than one Sent folder
This macro watches two sent items folders. You'll need the GetFolderPath function from Working with VBA and non-default Outlook Folders.
If you need to watch more than 2, duplicate these two lines:
Private WithEvents olSentAcct As items
Set olSentAcct = GetFolderPath("diane@contrarytoo.com\Sent Items").items
and the Private Sub olSentAcct_ItemAdd(ByVal item As Object)
sub.
Then change olSentAcct in each of the copied lines to something unique.
Option Explicit Dim strID As String, strLink As String, strLinkText As String Private WithEvents olSentItems As items Private WithEvents olSentAcct As items Private Sub Application_Startup() Dim objNS As NameSpace Set objNS = Application.Session ' instantiate objects declared WithEvents Set olSentItems = objNS.GetDefaultFolder(olFolderSentMail).items ' additional folders need to use GetFolderPath function ' http://slipstick.me/qf Set olSentAcct = GetFolderPath("diane@contrarytoo.com\Sent Items").items Set objNS = Nothing End Sub Private Sub olSentItems_ItemAdd(ByVal item As Object) ' if you need to set a different task folder for each acct ' set a variable to the folder here SaveasTask item End Sub Private Sub olSentAcct_ItemAdd(ByVal item As Object) ' if you need to set a different task folder for each acct ' set a variable to the folder here SaveasTask item End Sub Sub SaveasTask(ByVal item As Object) On Error Resume Next Dim prompt As String Dim oForward As MailItem prompt$ = "Do you want to create a Task for this message?" If MsgBox(prompt$, vbYesNo + vbQuestion + vbMsgBoxSetForeground, "Create Task?") = vbYes Then strID = item.EntryID strLink = "outlook:" & strID strLinkText = item.Subject CreateTaskForMessage item End If End Sub Sub CreateTaskForMessage(item As MailItem) Dim objTask As Outlook.TaskItem Dim objInsp As Outlook.Inspector Dim oForward As MailItem ' Add reference to Word library ' in VBA Editor, Tools, References Dim objDoc As Word.Document Dim objWord As Word.Application Dim objSel As Word.Selection Dim oBookmark As Word.Bookmark Set oForward = item.Forward oForward.Display Set objInsp = oForward.GetInspector If objInsp.EditorType = olEditorWord Then Set objDoc = objInsp.WordEditor Set objWord = objDoc.Application On Error Resume Next 'removes your signature from the top of the Forward If objDoc.Bookmarks.Exists("_MailAutoSig") Then Set oBookmark = objDoc.Bookmarks("_MailAutoSig") oBookmark.Select objDoc.Windows(1).Selection.Delete End If Set objSel = objWord.Selection With objSel .WholeStory .Copy End With End If Set objTask = Application.CreateItem(olTaskItem) Set objInsp = objTask.GetInspector Set objDoc = objInsp.WordEditor Set objSel = objDoc.Windows(1).Selection With objTask .Subject = oForward.Subject objSel.PasteAndFormat (wdFormatOriginalFormatting) objSel.GoTo What:=wdGoToSection, Which:=wdGoToFirst objDoc.Hyperlinks.Add objSel.Range, strLink, "", "", strLinkText, "" objSel.Range.InsertBefore "Link to " .ReminderSet = True .ReminderTime = DateSerial(Year(Now), Month(Now), Day(Now + 2)) + #9:00:00 AM# .Display .Save End With oForward.Close olDiscard End Sub
How to use the Macro
First: You will need macro security set to low during testing.
To check your macro security in Outlook 2010 and newer, go to File, Options, Trust Center and open Trust Center Settings, and change the Macro Settings. In Outlook 2007 and older, itâs at Tools, Macro Security. If Outlook tells you it needs to be restarted, close and reopen Outlook. Note: after you test the macro and see that it works, you can either leave macro security set to low or sign the macro.
Now open the VBA Editor by pressing Alt+F11 on your keyboard. Paste the macro on this page into ThisOutlookSession. You'll need to set a reference to Microsoft Word object library. If you receive a "User-defined type not defined" error, you don't have the reference to Word object library set.
- Go to Tools, References menu.
- Locate the object library in the list and add a check mark to it.
More information as well as screenshots are at How to use the VBA Editor.
More Information
Other macros to create tasks or appointments are at
Hello Diane - I recently ran into the issue that the code is not creating a new task, unless the VBA Window with the code is open. Any advise on what the issue could be?
Hello Diane:
I'm recently having trouble with the VBA, as it stops working when the new email is created. and the new task does not open. What it interesting, if I have my VBA window opened, this macro works. Any thoughts?
I have used this code of asking to create an apt or task after sending an email and now it is not working. No error message it is in the Outlook Instance and after sending an email nothing pops up. What am I missing or was there an update that broke it??
Add some msgbox "Macro is running" lines at points within the code then restart outlook.
Make sure the macro security was not changed.
So I missed the step about the Word Tools - Reference. When I checked that and restarted Outlook and tested the Task worked. Pulled a created task window and allowed me to save. When I tried the Appointment option it appeared to flash an Apt window went away and when I checked Calenda (says 2 days from Now) there were no appointments on my calendar anywhere. So, I am getting closer it seems but still missing something. I am running the most current version Outlook 365 Desktop version
So I missed the step about the Word Tools - Reference. When I checked that and restarted Outlook and tested the Task worked. Pulled a created task window and allowed me to save. When I tried the Appointment option it appeared to flash an Apt window went away and when I checked Calenda (says 2 days from Now) there were no appointments on my calendar anywhere. So, I am getting closer it seems but still missing something. I am running the most current version Outlook 365 Desktop version
Hi Diane. Very helpfull. Do have any Idee if we are able to compose the links for the OWA access? There is now a API to geht the weblink to an mail but no idea how to do it with Outlook VBA.
https://outlook.office365.com/api/v1.0/Me/Messages?$select=WebLink
from https://stackoverflow.com/questions/25511705/how-to-open-specific-email-item-in-owa-from-url
Thx A.
This won't work with the new Outlook on the web. :(
The "Choose Task or Appointment" VBS works! When I had it installed on my old PC, I could have sworn that when I chose the "Appointment" option, an Outlook appointment opened that was populated with the email that I just sent. At this point I'd update the date and time for the appointment and save it.
When I use this now, the appointment is automatically created at the date and time specified in the code: 2 days from now at 9:00 AM. When I check this appointment in my calendar, it is not there. When I run a search for it in "All outlook items" from email, I can find it. When I open this appointment from email search it works! Then when I check my calendar a subsequent time, it is there. The act of searching for the appointment is necessary to make it appear on my calendar. I did not believe my eyes and tried this a few times to test it.
In this auto-created appointment, the email does not populate into the body field of the appointment. Only the email subject populates into the appointment subject.
Hello Diane; I have migrated to a new Win10 PC running Outlook 2016 and I can't get this script working. I am getting a pop-up that reads. "Compile Error: User-Defined type not defined" despite Microsoft Word 16.0 Object Library. Your expertise would be appreciated.
Disregard the above question. My eyes are playing tricks on me. I did not notice a separate Office and Word Objects Libraries that are referenced.
Choose Task or Appointment - error
Compile error:
User-defined type not defined
Office 2016
Windows 10
64 bit
Any ideas?
Thanks!
Did you add a reference to the word object library in VBA Editor, Tools, References? not setting a reference s the usual cause of that error message.
Hi Diane!
That worked. But...now, testing the
(2nd Macro) Choose Task or Appointment
Creates tasks & appointments but they cannot be found anywhere. They are created and then fade to black *poof*. I can see that they are being created but, they are no where to be found.
(1st Macro)
Works but...instead of Task, creates only a Forwarded message with the body of the originally sent message.
How does this look to you?
Thanks!
A S U P E R F A N ! ! ! : ) ) )
Do you have more than one task folder? They should be going into the default task folder for your profile.
That's what was sooooo curious. They just went AWOL. Couldn't even search them. I intentionally added strings like
xybxyb
to the tasks and appointments to make them easier to search. They just...vanished.
Yeah, definitely weird in that case.
https://www.slipstick.com/developer/code-samples/create-task-sending-message/
This code is working. But, the task itself loses a lot of the email formatting.
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim intRes As Integer
Dim strMsg As String
Dim objTask As TaskItem
Set objTask = Application.CreateItem(olTaskItem)
Dim strRecip As String
strMsg = "Do you want to create a task for this message?"
intRes = MsgBox(strMsg, vbYesNo + vbExclamation, "Create Task")
If intRes = vbNo Then
Cancel = False
Else
For Each Recipient In Item.Recipients
strRecip = strRecip & vbCrLf & Recipient.Address
Next Recipient
With objTask
.Body = strRecip & vbCrLf & Item.Body
.Subject = Item.Subject
.Save
End With
Cancel = False
End If
Set objTask = Nothing
End Sub
Yes, because tasks don't support HTML. You can use the method at https://www.slipstick.com/developer/code-samples/create-task-selected-text/ to copy the body (use wholestory) and paste it into a task.
Will give it a go! If this can work then I'm all set. :D
Primero Fan
Hi Diane,
Within this code, where should I put the
.WholeStory
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim intRes As Integer
Dim strMsg As String
Dim objTask As TaskItem
Set objTask = Application.CreateItem(olTaskItem)
Dim strRecip As String
strMsg = "Do you want to create a task for this message?"
intRes = MsgBox(strMsg, vbYesNo + vbExclamation, "Create Task")
If intRes = vbNo Then
Cancel = False
Else
For Each Recipient In Item.Recipients
strRecip = strRecip & vbCrLf & Recipient.Address
Next Recipient
With objTask
.Body = strRecip & vbCrLf & Item.Body
.Subject = Item.Subject
.Save
End With
Cancel = False
End If
Set objTask = Nothing
End Sub
Many thanks!
you need more than wholestoryâĤ the CreateTaskForMessage macro above uses the word object model to copy and paste. (I missed it when i looked at the macros on this page earlier)
I put the code into your macro:
https://www.slipstick.com/macros/GTD-Task.txt
Hi Diane,
When I see how carefully and kindly you help people every day I feel impressed. Thanks, Diane! :)))
Tried the code and got
Compile error:
Sub or Function not defined
Opened the VB editor at
Set Item = GetCurrentItem()
The code that's working for me is below, from: https://www.slipstick.com/developer/code-samples/create-task-sending-message/
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim intRes As Integer
Dim strMsg As String
Dim objTask As TaskItem
Set objTask = Application.CreateItem(olTaskItem)
Dim strRecip As String
strMsg = "Do you want to create a task for this message?"
intRes = MsgBox(strMsg, vbYesNo + vbExclamation, "Create Task")
If intRes = vbNo Then
Cancel = False
Else
For Each Recipient In Item.Recipients
strRecip = strRecip & vbCrLf & Recipient.Address
Next Recipient
With objTask
.Body = strRecip & vbCrLf & Item.Body
.Subject = Item.Subject
.Save
End With
Cancel = False
End If
Set objTask = Nothing
End Sub
Sincerely,
A Fan!
>> Set Item = GetCurrentItem()
You need the GetCurrentItem function from https://www.slipstick.com/developer/outlook-vba-work-with-open-item-or-select-item/#getcurrentitem