Determine if sending from specific mailbox - vba

I would like add an acronym of my name at the end of the mail subject if sending it from a specific mailbox.
Example:
I have two mailboxes in Outlook, mail1#mail.com and mail2#mail.com.
When sending mail from mail1#mail.com the code should check if the acronym is present in the subject, if not add it.
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim xText As String
'text I would like to add at the end of mail subject
xText = "/MX"
If oAccount = "mail1#mail.com" Then 'part which does not work
If InStr(Item.Subject, xText) = False Then
Item.Subject = Item.Subject & " " & xText
End If
End If
End Sub

You should get the result required with .SendUsingAccount rather than Account.
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim xText As String
If Item.Class = olmail Then
'text I would like to add at the end of mail subject
xText = "/MX"
Debug.Print Item.SendUsingAccount
If Item.SendUsingAccount = "mail1#mail.com" Then
If InStr(Item.Subject, xText) = False Then
Debug.Print Item.Subject
'If item cannot be edited post another question
End If
End If
' for testing, cancel ALL sending
' remove to allow sending
Cancel = True
End Sub

Related

Get AppointmentItem data when Send is triggered

When I send an Outlook 2016 appointment, I use following to trigger a VBA code:
Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
How to display data specific to the type "AppointmentItem"?
I expect a Message Box "Do you want to talk about Computer at school",
but I get a Run-time error '438'.
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim prompt As String
prompt = "Do you want to talk about " & Item.Subject 'Works
prompt = prompt & " at " & Item.Location 'Error
If MsgBox(prompt, vbYesNo + vbQuestion, "Sample") = vbNo Then
Cancel = True
End If
End Sub
If you send a meeting request, the sent item itself is an olMeetingRequest and not an olAppoinmentItem.
You can address the corresponding appointment item by GetAssociatedAppointment
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim objAppointment As AppointmentItem
If Item.Class = olMeetingRequest Then
Set objAppointment = Item.GetAssociatedAppointment(False)
Debug.Print objAppointment.Subject
Debug.Print objAppointment.Location
End If
End Sub

Outlook attachment check

How do I make a VBA code or set up my mail in a way so that a message box shows up if I am sending an email with an attachment?
I have searched through many posts and haven't found a solution to this problem - I have found many solutions to check for missing attachments but so far I haven't found one where an alert is shown if an email has an attachment.
I would reference https://learn.microsoft.com/en-us/office/vba/api/Outlook.Application.ItemSend
and How can I automatically run a macro when an email is sent in Outlook?
as well as https://social.msdn.microsoft.com/Forums/sqlserver/en-US/c4f47790-8e7b-425a-bf7e-f7bc5b725e81/determine-attechments-in-mail-item?forum=outlookdev
These detail the ItemSend event with the example shown below.
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim prompt As String
prompt = "Are you sure you want to send " & Item.Subject & "?"
If MsgBox(prompt, vbYesNo + vbQuestion, "Sample") = vbNo Then
Cancel = True
End If
End Sub
The property of the MailItem you're looking for is Attachments.
The above example passes in the Item as an object-which should be a MailItem by default, so checking Item.Attachments.Count <> 0 would be true if it had attachments.
Try something along the lines of
Private Sub Application_ItemSend(ByVal Item as Object, Cancel as Boolean)
If Item.Attachments.Count > 0 Then
If Msgbox("Items attached to email. Send?", vbYesNo) = vbNo Then
Cancel = True
End If
End If
End Sub
To only flag messages with attachments at the subject line we can use the Attachment Property "PR_ATTACHMENT_HIDDEN" If it exists and the value is FALSE, it indicates an attached-at-subject-line attachment as opposed to an embedded image.
The quick On Error Resume Next is to catch the exception if PR_ATTACHMENT_HIDDEN isn't on any objects. It will throw an exception if it doesn't exist.
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Const PR_ATTACHMENT_HIDDEN As String = "http://schemas.microsoft.com/mapi/proptag/0x7FFE000B"
Dim aFound As Boolean
aFound = False
If TypeOf Item Is Outlook.MailItem Then
For Each a In Item.Attachments
On Error Resume Next ' to avoid the error thrown when no items within attachments have this property
If a.PropertyAccessor.GetProperty(PR_ATTACHMENT_HIDDEN) = False Then
aFound = True
Exit For
End If
On Error GoTo 0
Next a
If aFound = True Then
If MsgBox("Items attached to email. Send?", vbYesNo) = vbNo Then
Cancel = True
End If
End If
End If
End Sub
If you are trying to discriminate between images within signatures and embedded images we need to review the content ID against the HTML body of the email for the tag. I added another check to the code to find those and disregard them as false positives.
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Const PR_ATTACH_CONTENT_ID As String = "http://schemas.microsoft.com/mapi/proptag/0x3712001F"
Const PR_ATTACHMENT_HIDDEN As String = "http://schemas.microsoft.com/mapi/proptag/0x7FFE000B"
Dim aFound As Boolean
aFound = False
If TypeOf Item Is Outlook.MailItem Then
For Each a In Item.Attachments
On Error Resume Next ' to avoid the error thrown when no items within attachments have this property
If a.PropertyAccessor.GetProperty(PR_ATTACHMENT_HIDDEN) = False Then
If Len(a.PropertyAccessor.GetProperty(PR_ATTACH_CONTENT_ID)) > 0 And InStr(Application.ActiveInspector.CurrentItem.HTMLBody, a.PropertyAccessor.GetProperty(PR_ATTACH_CONTENT_ID)) Then
Else
aFound = True
Exit For
End If
End If
On Error GoTo 0
Next a
If aFound = True Then
If MsgBox("Items attached to email. Send?", vbYesNo) = vbNo Then
Cancel = True
End If
End If
End If
End Sub

Macro not working after outlook restart

I have a code which checks subject and email for a specific string and notifies users with YES/NO option.
When I restart outlook, I need to manually run MACRO to make it work.
I tried below code but I still need to run it manually.
Public WithEvents PasswordCheck As Outlook.Application
Public Sub Initialize_handler()
Set PasswordCheck = Outlook.Application
End Sub
Private Sub PasswordCheck_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim strBody As String
Dim strSubject As String
strSubject = Item.Subject
strBody = Item.Body
UCasePasswd = UCase("Test_123")
prompt = "Are you sure you want to send this email? It contains Password: "
If InStr(1, UCase(strSubject), UCasePasswd) > 0 Or _
InStr(1, UCase(strBody), UCasePasswd) > 0 Then
If MsgBox(prompt, vbYesNo + vbQuestion, "Check for Subject") = vbNo Then
Cancel = True
End If
End If
End Sub
Private Sub PasswordCheck_Startup()
Initialize_handler
End Sub
Change your procedure name
Private Sub PasswordCheck_ItemSend(ByVal Item As Object, Cancel As Boolean)
should be
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
and be stored in the ThisOutlookSession module.
You should also place Option Explicit at the top of your module and declare UCasePasswd and prompt as string variables.
After testing this code worked without need to call it with the Application_Startup() routine as it's a built in event.
Also, I don't think you can re-reference Application_Startup as PasswordCheck_Startup the same way I've never seen Private Sub Workbook_Open() changed to anything else in Excel.
Edit:
This code in ThisOutlookSession worked perfectly - it's the only code in the module.
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim strBody As String
Dim strSubject As String
Dim UCasePasswd As String
Dim prompt As String
strSubject = Item.Subject
strBody = Item.Body
UCasePasswd = "TEST_123" 'Rather than use UCASE, just write it in upper case.
prompt = "Are you sure you want to send this email? It contains Password: "
If InStr(UCase(strSubject), UCasePasswd) > 0 Or InStr(UCase(strBody), UCasePasswd) > 0 Then
If MsgBox(prompt, vbYesNo + vbQuestion, "Check for Subject") = vbNo Then
Cancel = True
End If
End If
End Sub

Prompt for Subject Line When Creating a New Email

I use 2007 Outlook.
I'm trying to get a code that upon creation of a new email prompts the user to pick one of the fixed radio button options as follows [A]: , [R]:, [F:] , [!]: , Blank (Option to get subject line blank).
I want that selection to be inserted into the subject line automatically.
I found code online but it errors out towards the end of the code.
Private Sub m_colInspectors_NewInspector(ByVal Inspector As Outlook.Inspector)
I pasted this code in the ThisOutlookSession module.
Option Explicit
Private WithEvents m_colInspectors As Outlook.Inspectors
Private WithEvents CurrentInspector As Outlook.Inspector
Private Sub Application_Startup()
Set m_colInspectors = Application.Inspectors
End Sub
Private Sub CurrentInspector_Activate()
Dim oMail As Outlook.MailItem
If Len(UserForm1.SelectedSubject) Then
Set oMail = CurrentInspector.CurrentItem
oMail.Subject = UserForm1.SelectedSubject
End If
Set CurrentInspector = Nothing
End Sub
Private Sub m_colInspectors_NewInspector(ByVal Inspector As Outlook.Inspector)
If TypeOf Inspector.CurrentItem Is Outlook.MailItem Then
If Inspector.CurrentItem.EntryID = vbNullString Then
UserForm1.SelectedSubject = vbNullString
UserForm1.Show
Set CurrentInspector = Inspector
End If
End If
End Sub
I created a form with radio button and a command button where I inserted the following code.
Option Explicit
Public SelectedSubject As String
Private Sub CommandButton1_Click()
If OptionButton1.Value = True Then
SelectedSubject = "Test"
End If
Hide
End Sub
This might get you want you want. Put it under ThisOutlookSession. When the user click on Sends this triggers, meaning they are not able to change the subject line before it is sent. I am using the UserForm1 and the code you are using for that. Add as many radiobuttons as you like and just amend the OptionButton1 to 2 and the value.
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim strSubject As String
Dim Prompt$
strSubject = Item.Subject
' Show RadioButtons
UserForm1.Show
' Set Subject Line as the value from the selected RadioButton
strSubject = UserForm1.SelectedSubject
' Set the message subject
Item.Subject = strSubject
strSubject = Item.Subject
' Test if Subject Line is empty
If Len(Trim(strSubject)) = 0 Then
Prompt$ = "Subject is Empty. Are you sure you want to send the Mail?"
If MsgBox(Prompt$, vbYesNo + vbQuestion + vbMsgBoxSetForeground, "Check for Subject") = vbNo Then
Cancel = True
End If
End If
End Sub

Run macro when email is sent

I am trying to write a macro that looks at the subject line of an email whenever the user hits the Send button.
However I can't find any documentation that listens to that button. For right now I am just trying to get it to send a MsgBox with the subject when the email is sent. Is there a way to listen (thinking in terms of DOMs) to this button and fire a macro on the click.
As suggested by Siddharth:
I have written a small demo which checks some conditions to decide, if the send operation should be canceled. This could be extended to do other things like inserting dates, saving the mails to some folder, ...
Option Explicit
Private Sub Application_ItemSend(ByVal objItem As Object, Cancel As Boolean)
Dim mi As MailItem
If TypeName(objItem) = "MailItem" Then
Set mi = objItem
Debug.Print mi.Subject
check Cancel, Trim(mi.Subject) <> "", "Subject is empty!"
check Cancel, Not isRecipient(mi, "John#Doe.net"), _
"John is on our embargo list!"
End If
End Sub
Private Sub check(ByRef Cancel As Boolean, cond As Boolean, msg As String)
If Not (Cancel Or cond) Then
Cancel = (MsgBox(msg & vbCrLf & "Cancel send operation?", _
vbYesNoCancel, "Confirm?") <> vbNo)
End If
End Sub
Private Function isRecipient(mi As MailItem, forbidden As String) As Boolean
Dim ret As Boolean
Dim rc As Recipient
ret = False
For Each rc In mi.recipients
If StrComp(rc.Address, forbidden, vbTextCompare) = 0 Then
ret = True
Exit For
End If
Next
isRecipient = ret
End Function