I would like to be able to create a task from a Sent email in Outlook at the time of sending. It is find if a button pops up asking me if I want a task, and I have to click Yes or No. I found the code below. But if I click Yes, it creates the task without me editing it. I just want the Task window to pop up with the email I sent populating it, but I want to add the dates etc. Can anyone help please?
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
'Updated by Extendoffice 20181123
Dim xYesNo As Integer
Dim xPrompt As String
Dim xTaskItem As TaskItem
Dim xRecipient As String
On Error Resume Next
xPrompt = "Do you want to create a task for this message?"
xYesNo = MsgBox(xPrompt, vbYesNo + vbInformation, "Kutools for Outlook")
Cancel = False
If xYesNo = vbNo Then Exit Sub
Set xTaskItem = Application.CreateItem(olTaskItem)
For Each Rcp In Item.Recipients
If xRecipient = "" Then
xRecipient = Rcp.Address
Else
xRecipient = xRecipient & vbCrLf & Rcp.Address
End If
Next Rcp
xRecipient = xRecipient & vbCrLf & Item.Body
With xTaskItem
.Subject = Item.Subject
.StartDate = Item.ReceivedTime
.DueDate = Date + 3 + CDate("9:00:00 AM")
.ReminderSet = True
.ReminderTime = Date + 2 + CDate("9:00:00 AM")
.Body = xRecipient
.Save
End With
Set xTaskItem = Nothing
End Sub
You need to call the Display method if you need to show an Outlook inspector window for editing task properties:
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
'Updated by Extendoffice 20181123
Dim xYesNo As Integer
Dim xPrompt As String
Dim xTaskItem As TaskItem
Dim xRecipient As String
On Error Resume Next
xPrompt = "Do you want to create a task for this message?"
xYesNo = MsgBox(xPrompt, vbYesNo + vbInformation, "Kutools for Outlook")
Cancel = False
If xYesNo = vbNo Then Exit Sub
Set xTaskItem = Application.CreateItem(olTaskItem)
For Each Rcp In Item.Recipients
If xRecipient = "" Then
xRecipient = Rcp.Address
Else
xRecipient = xRecipient & vbCrLf & Rcp.Address
End If
Next Rcp
xRecipient = xRecipient & vbCrLf & Item.Body
With xTaskItem
.Subject = Item.Subject
.StartDate = Item.ReceivedTime
.DueDate = Date + 3 + CDate("9:00:00 AM")
.ReminderSet = True
.ReminderTime = Date + 2 + CDate("9:00:00 AM")
.Body = xRecipient
.Display
End With
Set xTaskItem = Nothing
End Sub
In that case the original window should be closed and the email is sent out. But you will get the task item window opened for editing its properties. If you need to delay the send process until you are done with task properties editing process you may pass true to the Display method to stop the execution of the ItemSend event handler and wait until the dialog window is closed.
I'm trying to prompt if sending from a personal account in Outlook.
I have the following which works 90% of the time, however sometimes it errors with the following:
You cannot send an item that is already in the process of being sent
Code for reference:
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim Send_Address As String
Dim Prompt As String
' Check Send_From name
Send_Address = Item.SendUsingAccount
Select Case Send_Address
Case "example#domain.uk"
Case Else
Prompt = "You are currently sending this email from " & Send_Address & "" & vbNewLine & "Do you want to proceed?"
If MsgBox(Prompt, vbYesNo + vbQuestion + vbMsgBoxSetForeground, "Check Address") = vbNo Then
Cancel = True
End If
End Select
End Sub
You can't cast an instance of the Account class to a string:
Dim Send_Address As String
Dim Prompt As String
' Check Send_From name
Send_Address = Item.SendUsingAccount
The SendUsingAccount property returns or sets an Account object that represents the account under which the MailItem is to be sent. The SendUsingAccount property can be used to specify the account that should be used to send the MailItem when the Send method is called. This property returns Null (Nothing in Visual Basic) if the account specified for the MailItem no longer exists. For example, here is a sample use case:
Sub SendUsingAccount()
Dim oAccount As Outlook.account
For Each oAccount In Application.Session.Accounts
If oAccount.AccountType = olPop3 Then
Dim oMail As Outlook.MailItem
Set oMail = Application.CreateItem(olMailItem)
oMail.Subject = "Sent using POP3 Account"
oMail.Recipients.Add ("someone#example.com")
oMail.Recipients.ResolveAll
Set oMail.SendUsingAccount = oAccount
oMail.Send
End If
Next
End Sub
So, to check the SMTP address you need to use the following code:
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim account as Outlook.Account
Dim Send_Address As String
Dim Prompt As String
' Check Send_From name
Set account = Item.SendUsingAccount
If Not account Is Nothing then
Send_Address = account.SmtpAddress
Select Case Send_Address
Case "example#domain.uk"
Case Else
Prompt = "You are currently sending this email from " & Send_Address & "" & vbNewLine & "Do you want to proceed?"
If MsgBox(Prompt, vbYesNo + vbQuestion + vbMsgBoxSetForeground, "Check Address") = vbNo Then
Cancel = True
End If
End Select
End If
End Sub
I want to validate that the outgoing email is correctly attached with a correct file. The email subject contains a code. The attachment filename is automatically generated with a code and attached manually to the email. The VBA is to check whether the email subject contains a common pattern in the filename of the attachment.
The code is like H??#######, i.e. it must start with "H", followed with 2 letters, and then 7 digits.
If both the email subject and filename contain the same code, the email is allowed to send, otherwise it should warn. For example:
Subject: Urgent Chapter 10 - HCX1234567 updated on 12 Dec 2015
Filename: HCX1234567_ABCCh10_20151212_0408
This email is allowed.
Is it possible to do such validation before sending?
Here is my attempt:
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
'Create Geoff Lai on 14 March 2016
Dim recips As Outlook.Recipients
Dim recip As Outlook.Recipient
Dim pa As Outlook.PropertyAccessor
Dim prompt As String
Dim strMsg As String
Dim mailContent As String
Dim jobCode As String
Dim attachName As String
Dim pos As Integer
Dim jcodepos As Integer
Const PR_SMTP_ADDRESS As String = "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
attachName = Item.Attachments.Item(1).FileName
mailContent = Item.Body + Item.Subject ' Get a copy of all the e-mail body text and subject text to search.
mailContent = LCase(mailContent) ' Make whole string lowercase for easier searching.
Set recips = Item.Recipients
For Each recip In recips 'Record email addressees if send to external domain
Set pa = recip.PropertyAccessor
If InStr(LCase(pa.GetProperty(PR_SMTP_ADDRESS)), "#mydomain.com") = 0 Then
strMsg = strMsg & " " & pa.GetProperty(PR_SMTP_ADDRESS) & vbNewLine
End If
Next
If strMsg <> "" Then
If (Item.Attachments.Count = 0) Then ' Check attachment
If InStr(1, mailContent, "attach") > 0 Then
pos = 1
ElseIf InStr(1, mailContent, "Attach") > 0 Then
pos = 1
ElseIf InStr(1, mailContent, "enclose") > 0 Then
pos = 1
ElseIf InStr(1, mailContent, "Enclose") > 0 Then
pos = 1
Else: pos = 0
End If
End If
If (pos > 0) Then 'If there is no attachment:
If MsgBox("With the word attach or enclose, attachment should be found in this email" & vbNewLine & "Please Confirm.", vbYesNo + vbCritical + vbMsgBoxSetForeground, "Missing Attachment") = vbYes Then
prompt = "This email will be sent outside of mydomain.com to:" & vbNewLine & strMsg & "Do you want to proceed?"
If MsgBox(prompt, vbYesNo + vbExclamation + vbMsgBoxSetForeground, "Check Address") = vbNo Then
Cancel = True
Exit Sub
Else
Exit Sub
End If
Else
Cancel = True 'Stop sending
End If
End If
If (Item.Attachments.Count > 0) Then ' Validate attachment and subject
jcodepos = InStr(1, attachName, "H??#######", 0) ' Get job code position
jobCode = Mid(attachName, jcodepos, 10) ' Get job code
If (InStr(1, Item.Subject, jobCode, 0) = 0) Then ' If no common code between subject and attachment
If MsgBox("There is no common job code between the email subject and the filename of the attachment." & vbNewLine & "Do you want to proceed?", _
vbYesNo + vbCritical + vbMsgBoxSetForeground, "Wrong Attachment?") = vbNo Then
Cancel = True
Exit Sub
Else
Exit Sub
End If
ElseIf MsgBox("Common job code " & jobCode & " is found in the email subject and the filename of the attachment" & prompt, _
vbYesNo + vbQuestion + vbMsgBoxSetForeground, "Confirm Job Code") = vbNo Then ' If common code is found
Cancel = True
Exit Sub
Else
Exit Sub
End If
End If
End If
End Sub
However, I get an error at jobCode = Mid(attachName, jcodepos, 10), which is:
Run-time error '5' Invalid procedure call or argument
Application_ItemSend, the usual way, in ThisOutlookModule. How can I automatically run a macro when an email is sent in Outlook?
In the VB editor set the reference to Regular Expressions.
Similar to the code in the Question part of Regular Expression Rules in Outlook 2007?. Check RegEx.Pattern = "(H[A-Z]{2}[0-9]{7})" against the filename. Continue with RegEx or InStr to verify the subject includes the filename match.
Since you thinking about using VBA I would assume that you are using Outlook as your email client. If so, please add this to your question and the tags. With this assumption the answer is that it depends:
If Outlook is actually used to send the email then it can be done. The following Q&A is probably a good starting point.
how to check details before sending mails in outlook using macros?
Yet, the above technique will not work if the email is created with File | Send commands in Office programs or similar commands in Windows Explorer or other programs.
Finally, I have figured it out, Thanks for the advices!
Here is my workout.
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim recips As Outlook.Recipients
Dim recip As Outlook.Recipient
Dim pa As Outlook.PropertyAccessor
Dim regex As Object, codeInSubject As Object, codeInAttach As Object
Dim matchSbjtCode As String, matchAttchcode As String
Dim prompt As String
Dim strMsg As String
Dim mailContent As String
Dim attachName As String
Dim pos As Integer
Const PR_SMTP_ADDRESS As String = "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
Set regex = CreateObject("vbScript.regExp")
With regex
.Pattern = "[H][ACDILNOPQTUVW][BCGJMOPRSTWY][1-9][0-9]{6}" ' Set regular expression pattern
.Global = False ' Check the first instance only
End With
attachName = Item.Attachments.Item(1).FileName
mailContent = Item.Body + Item.Subject ' Get a copy of all the e-mail body text and subject text to search.
mailContent = LCase(mailContent) ' Make whole string lowercase for easier searching.
Set recips = Item.Recipients
For Each recip In recips 'Record email addressees if send to external domain
Set pa = recip.PropertyAccessor
If InStr(LCase(pa.GetProperty(PR_SMTP_ADDRESS)), "#mydomain.com") = 0 Then
strMsg = strMsg & " " & pa.GetProperty(PR_SMTP_ADDRESS) & vbNewLine
End If
Next
prompt = "This email will be sent outside of mydomain.com to:" & vbNewLine & strMsg & "Do you want to proceed?"
If strMsg <> "" Then
If (Item.Attachments.Count = 0) Then ' Check attachment
If InStr(1, mailContent, "attach") > 0 Then
pos = 1
ElseIf InStr(1, mailContent, "enclose") > 0 Then
Else: pos = 0
End If
End If
If (pos > 0) Then 'If there is no attachment:
If MsgBox("With the word 'attach' or 'enclose', attachment should be found in this email" & vbNewLine & _
"Please Confirm.", vbYesNo + vbCritical + vbMsgBoxSetForeground, "Missing Attachment") = vbYes Then ' Prompt to check
If MsgBox(prompt, vbYesNo + vbExclamation + vbMsgBoxSetForeground, "Check Address") = vbNo Then
Cancel = True
Exit Sub
Else
Exit Sub
End If
Else
Cancel = True 'Stop sending
End If
End If
If (Item.Attachments.Count > 0) Then ' Validate attachment and subject
If regex.test(Item.Subject) And regex.test(attachName) Then ' Test the job codes in the email subject and attachment filename
Set codeInSubject = regex.Execute(Item.Subject)
Set codeInAttach = regex.Execute(attachName)
If StrComp(codeInSubject(0), codeInAttach(0)) = 0 Then ' Compare the codes found
If MsgBox("Common job code """ & codeInAttach(0) & """ is found in the email subject and the filename of the attachment. " & vbNewLine & prompt, _
vbYesNo + vbQuestion + vbMsgBoxSetForeground, "Confirm Job Code") = vbNo Then ' If found, confirm to send
Cancel = True
Else: Exit Sub
End If
ElseIf MsgBox("There is no common job code between the email subject and the filename of the attachment." & vbNewLine & _
"Do you want to DISCARD?", vbYesNo + vbCritical + vbMsgBoxSetForeground, "Wrong Attachment?") = vbYes Then ' if not found, discard
Cancel = True
Else: Exit Sub
End If
End If
End If
End If
End Sub
I have little VBA experience so I found a few post that were kinda like what I want but I can't seem to make them work.
I would like a to add an email address to outlook as a Bcc and send it.
It goes under thisOutlookSession
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim olRecip As Recipient
Dim olMsg As String
Dim res As Integer
Dim olBcc As String
On Error Resume Next
'// set email address here
olBcc = "Address#domain.com"
Set olRecip = Item.Recipients.Add(olBcc)
olRecip.Type = olBcc
If Not olRecip.Resolve Then
olMsg = "Could not resolve Bcc recipient. " & _
"Do you still want to send?"
res = MsgBox(olMsg, vbYesNo + vbDefaultButton1, _
"Could Not Resolve Bcc Recipient")
If res = vbNo Then
Cancel = True
End If
End If
Set olRecip = Nothing
End Sub
I have a script I've pieced together over time. Recently a plugin we need to use in Outlook has caused some issues. Basically we get prompted twice because when the plugin is used the e-mail ends up being destroyed and re-created with a specific attachment filename. At this point the user is prompted again. I've tried to work in a For loop to skip the script if it finds this attachment. However, when I added the For loop it just seems to skip the entire script. I have limited experience with VBA and so I'm sure it's an issue with my syntax or usage. See script below:
Private Sub Application_ItemSend _
(ByVal Item As Object, Cancel As Boolean)
Dim strMsg As String
Dim Atmt As Variant
'strMsg = Item.Class
If Item.Class = "43" Then
For Each Atmt In Item.Attachments
If VBA.Right(Atmt.FileName, 3) = ".sf" Then
GoTo NonEmailError
End If
Next Atmt
If Item.CC = "" Then
strMsg = "To recipients: " & Item.To & vbCrLf & _
"Are you sure you want to send this message?"
Else
strMsg = "To recipients: " & Item.To & vbCrLf & _
"Cc recipients: " & Item.CC & vbCrLf & _
"Bcc recipients: " & Item.BCC & vbCrLf & _
"Are you sure you want to send this message?"
End If
Else
GoTo NonEmailError
End If
' Exit Sub
' Ignore errors for now.
On Error GoTo NonEmailError
' Prompt user to fill in subject
If Item.Subject = "" Then
MsgBox "You must enter a subject.", 48, "Empty Subject"
Cancel = True
GoTo NonEmailError
End If
' Exit Sub
' Prompt user to verify E-Mails
If MsgBox(strMsg, vbYesNo + vbQuestion _
, "Send Confirmation") = vbNo Then
Cancel = True
End If
Exit Sub
NonEmailError:
' The item being sent was not an e-mail and so don't prompt the user anything
Exit Sub
End Sub
I am not that familiar with outlook and VBA, but my first guess in this case is that item.class should be compared to the numeric value 43 rather than the string-literal value "43".
The one thing that gives me pause is that I would expect the statement to throw an error because "43" is the wrong type for Item.Class, but this may just reflect my unfamiliarity with the material.
According to msdn reference, item.class (in this case a mailItem) is an OlObjectClass constant, and 43 is olMail. It would probably be advisable to change:
If Item.Class = "43" Then
to
If Item.Class = olMail Then
or at least to:
If Item.Class = 43 Then
( see: http://msdn.microsoft.com/en-us/library/bb208118%28v=office.12%29.aspx and http://msdn.microsoft.com/en-us/library/bb207137%28v=office.12%29.aspx )