Prompt for password when sending - vba

I want Outlook to prompt for a password or some sort of authentication on all outgoing mail items, because someone keeps sending on behalf on my account.
I have written:
If Omail.SendUsingAccount = "My Domain Email account typed here" Then
Sub password()
Dim pass As String
pass = InputBox("Enter Password")
If pass <> "thepassword" Then Exit Sub
End Sub
This doesn't work. After I have the correct code can I then just insert that into a custom action rule?

Please use the below code:
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
prompt$ = "Enter Password to Send Mail"
Dim pass As String
pass = InputBox("Enter Password")
If pass <> "yourpwd" Then
Cancel = True
End If
End Sub
Its tested and its working fine.
make sure you have enabled macro from trust centre.

You can develop a VBA macro where you can handle the ItemSend event of the Application class which is fired whenever an Microsoft Outlook item is sent, either by the user through an Inspector (before the inspector is closed, but after the user clicks the Send button) or when the Send method for an Outlook item, such as MailItem, is used in a program.
For example:
Public WithEvents myOlApp As Outlook.Application
Public Sub Initialize_handler()
Set myOlApp = Outlook.Application
End Sub
Private Sub myOlApp_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
You may find the Getting Started with VBA in Outlook 2010 article helpful.

Related

Automatically "Send on Behalf Of" when sent from a specific email account

I could use assistance modifying the Outlook VBA macro. Any time I reply to an e-mail from any of my multiple e-mail accounts the script will change the sender address to the one specified (i.e. user#domain.com on behalf of group#domain.com). I like this behavior but need help making a change so that this script only runs when I am sending from an email address #domain.com. Essentially I would like the macro to have an if statement specifying if sending from an #domain.com email account then run the macro otherwise if sending from another email account i.e. user#gmail.com do not run the macro.
'================================================================================
'Description: Outlook macro to automatically set a different
' From address.
'
'Comment: You can set the email address at the bottom of the code.
' Uncomment the myOlExp_InlineResponse sub to also make it
' work with the Reading Pane reply feature of Outlook 2013/2016/2019/365.
'
' author : Robert Sparnaaij
' version: 1.1
' website: https://www.howto-outlook.com/howto/setfromaddress.htm
'================================================================================
Dim WithEvents objInspectors As Outlook.Inspectors
Dim WithEvents objMailItem As Outlook.MailItem
Dim WithEvents myOlExp As Outlook.Explorer
Private Sub Application_Startup()
Initialize_handler
End Sub
Public Sub Initialize_handler()
Set objInspectors = Application.Inspectors
Set myOlExp = Application.ActiveExplorer
End Sub
Private Sub objInspectors_NewInspector(ByVal Inspector As Inspector)
If Inspector.CurrentItem.Class = olMail Then
Set objMailItem = Inspector.CurrentItem
If objMailItem.Sent = False Then
Call SetFromAddress(objMailItem)
End If
End If
End Sub
'Uncomment the next 3 lines to enable Outlook 2013/2016/2019/365 Reading Pane Reply
'Private Sub myOlExp_InlineResponse(ByVal objItem As Object)
' Call SetFromAddress(objItem)
'End Sub
Public Sub SetFromAddress(oMail As Outlook.MailItem)
' Set your preferred default From address below.
' Exchange permissions determine if it is actually stamped
' as "Sent On Behalf Of" or "Sent As".
' The address is not properly updated for the InlineResponse
' feature in Outlook 2013/2016/365. This is only a visual bug.
oMail.SentOnBehalfOfName = "delegate#domain.com"
End Sub
Navigate the folder tree up to the email address folder.
This should be objMailItem.Parent.Parent.
Private Sub objInspectors_NewInspector(ByVal Inspector As Inspector)
If Inspector.currentItem.Class = olMail Then
Set objMailItem = Inspector.currentItem
If objMailItem.Sent = False Then
Debug.Print objMailItem.Parent.Parent
If InStr(LCase(objMailItem.Parent.Parent), LCase("#domain.com")) Then
Call SetFromAddress(objMailItem)
End If
End If
End If
End Sub
If you want to handle outgoing emails you need to subscribe to the ItemSend event of the Application class which is fired whenever an Microsoft Outlook item is sent, either by the user through an Inspector (before the inspector is closed, but after the user clicks the Send button) or when the Send method for an Outlook item, such as MailItem, is used in a program.
Public WithEvents myOlApp As Outlook.Application
Public Sub Initialize_handler()
Set myOlApp = Outlook.Application
End Sub
Private Sub myOlApp_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
In the event handler you may check out the MailItem.SendUsingAccount property which allows setting 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.
Depending on the account set on the mail item you may want to set the MailItem.SentOnBehalfOfName property which returns a string indicating the display name for the intended sender of the mail message. You may need to cancel the default action and re-submit the item anew programmatically.
For anyone who finds this.
This should work if you already have the primary account setup in outlook and the account you want to send from has "send on behalf" or "send as" permission:
Dim WithEvents objInspectors As Outlook.Inspectors
Dim WithEvents objMailItem As Outlook.MailItem
Dim WithEvents myOlExp As Outlook.Explorer
Private Sub Application_Startup()
Initialize_handler
End Sub
Public Sub Initialize_handler()
Set objInspectors = Application.Inspectors
Set myOlExp = Application.ActiveExplorer
End Sub
Private Sub objInspectors_NewInspector(ByVal Inspector As Inspector)
If Inspector.CurrentItem.Class = olMail Then
Set objMailItem = Inspector.CurrentItem
If objMailItem.Sent = False Then
Call SetFromAddress(objMailItem)
End If
End If
End Sub
'Uncomment the next 3 lines to enable Outlook 2013/2016/2019/365 Reading Pane Reply
'Private Sub myOlExp_InlineResponse(ByVal objItem As Object)
'Call SetFromAddress(objItem)
'End Sub
Public Sub SetFromAddress(oMail As Outlook.MailItem)
' Set your preferred default From address below.
' Exchange permissions determine if it is actually stamped
' as "Sent On Behalf Of" or "Sent As".
' The address is not properly updated for the InlineResponse
' feature in Outlook 2013/2016/365. This is only a visual bug.
If oMail.SendUsingAccount = "primary#domain" Then
oMail.SentOnBehalfOfName = "delegate#domain"
End If
End Sub

Popup will show in the outlook for unwanted recipient

I have a list of 150 people and I don't want to send any email apart from the list. Is it possible to set a macro in the outlook where if I try to send any email to the email id which is not present in the list, I will get a popup before sending the email ?
Yes, it is. You can handle the ItemSend event of the Application class which is fired whenever an Microsoft Outlook item is sent, either by the user through an Inspector (before the inspector is closed, but after the user clicks the Send button) or when the Send method for an Outlook item, such as MailItem , is used in a program.
Public WithEvents myOlApp As Outlook.Application
Public Sub Initialize_handler()
Set myOlApp = Outlook.Application
End Sub
Private Sub myOlApp_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
Instead of simply displaying a message box asking users permissions to send an Outlook item you may check the Recipients collection (see the corresponding property of the Outlook item). It represents all the recipients for the Outlook item. So, you may check them and compare with your list.

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

Intercept Email Before Sent by Pastel

Sage Pastel Evolution is unable to send emails in HTML format.
I am trying to intercept email before it is sent, add information to the subject and body in HTML format.
I placed the following in the ThisOutlookSession module:
Option Explicit
Public WithEvents myOlApp As Outlook.Application
Public Sub Initialize_Handler()
Set myOlApp = Outlook.Application
End Sub
Private Sub myOlApp_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim sPrompt As String
sPrompt = "Are you sure you want to send " & Item.Subject & "?"
If MsgBox(sPrompt, vbYesNo + vbQuestion, "Sample") = vbNo Then
Cancel = True
End If
End Sub
Nothing seems to be happening when I send an email, neither through Evolution nor through Outlook.
Remove everything and try just the following code, make sure to restart Outlook before testing
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
If you use this format, you have to run Initialize_Handler.
If you wish, instead of running it manually, you could do this when Outlook starts.
In the ThisOutlookSession module.
Private Sub Application_Startup
Initialize_Handler
End Sub

How can I automatically run a macro when an email is sent in Outlook?

The script below works great but I have to manually run the Initialize_handler routine every time I open Outlook for it to work.
Public WithEvents myOlApp As Outlook.Application
Public Sub Initialize_handler()
Set myOlApp = CreateObject("Outlook.Application")
End Sub
Private Sub myOlApp_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
As far as I can see to make this work automatically I should be able to add the below script to ThisOutlookSession. However this doesn't work and I have no idea why.
My macro security is set properly and it is running the code on startup but for some reason it doesn't work until I manually open the VBA editor click into Initialize_handler and press F5.
Private Sub Application_Startup()
Initialize_handler
End Sub
The convoluted method described here https://msdn.microsoft.com/en-us/library/office/ff865076.aspx indicates "The sample code must be placed in a class module".
I suggest you use the special class module ThisOutlookSession only. You could experiment with your own class module but if you just want this to work then replace all your code with this in ThisOutlookSession.
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
You can instead put it directly in ThisOutlookSession:
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
MsgBox "Sent somthing!"
End Sub
As simple as that. Note you need to change your outMail.Display to outMail.Display (True) and there you are, full code:
...
...
...
outMail.Display (True)
On Error Resume Next
bSent = outMail.sent 'This will NOT SEND. Used to get error.
If Err <> 0 Then
'Email was sent. Put followed actions here.
Else
'Email was not sent. Put followed actions here.
End If
On Error GoTo 0
Pros:
You get what you want
It's simple.
Cons:
Excel (or any other runtime you are running this code from) will freeze until you cancel or send email.