Outlook VBA Code to ask password before sending email

[js1537]

Hi,

I need outlook vba code which ask for predefined password before sending email. If password matches then outlook should send the email.

Please assist.

 

[D3allamerican07]

js1537,

If you already have the email code created, you can add this simple portion to it, to make the user enter a password. If the password does not match, it continues to prompt the user until correct. Change "Password" to your preference.

While passCode <> "[B][I][U]Password[/U][/I][/B]"
    
    passCode = InputBox("Enter password:      (If unknown, leave blank and click Cancel)", "Email Security")
    
    If passCode = "" Then
        Exit Sub
    End If
Wend

Let me know if this is something you were looking for.

Bill

 

[ZVI]

Hi,
Put this code into ThisOutlookSession module^

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
  Const PWD = "1234"  ' <-- Correct password
  Dim s As String
  s = InputBox("To send email type the password, please", "Email guard")
  If s <> PWD Then
    Cancel = True
    If s <> "" Then MsgBox "Wrong password!", vbExclamation, "Email guard"
  End If
End Sub

Regards

 

[js1537]

Thanks for replying Bill.

I need the complete email code with this password functionality in which password needs to be entered before sending the any email in outlook.

and

I need the complete email code in which if certain keywords are present in Subject or mail body (e.g. "Party" or "Treat") then an email cannot be sent.

Please assist.

 

[ZVI]

...I need the complete email code with this password functionality in which password needs to be entered before sending the any email in outlook...

See the code in post #3

 

[ZVI]

...
and I need the complete email code in which if certain keywords are present in Subject or mail body (e.g. "Party" or "Treat") then an email cannot be sent.

Put this code into Outlook's module ThisOutlookSession and try to send email with/without forbidden words.

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
'ZVI:2017-11-23 https://www.mrexcel.com/forum/excel-questions/1032508-outlook-vba-code-ask-password-before-sending-email.html
 
  ' --> Settings, change to suit
  Const cPwd = "1234"             ' The password
  Const cWords = "Party,Treat"    ' Forbidden words in Subject or Body
  Const cCaption = "Email guard"  ' Caption of MsgBox
  ' <-- End of the settings
 
  ' Variables
  Dim s As String, sSubj As String, sBody As String, w
 
  ' Exit if it's not email
  If TypeName(Item) <> "MailItem" Then Exit Sub
 
  ' Don't send if forbidden word is in the Subject or Body
  sSubj = Item.Subject
  sBody = Item.BODY
  For Each w In Split(cWords, ",")
    s = Trim(w)
    If InStr(1, sSubj, s, vbTextCompare) > 0 Then s = "Subject": Exit For
    If InStr(1, sBody, s, vbTextCompare) > 0 Then s = "Body": Exit For
  Next
  If Len(w) > 0 Then
    Cancel = True
    MsgBox "Forbidden word found in the " & s & ":" & vbLf & w, vbExclamation, cCaption
    Exit Sub
  End If
 
  s = InputBox("To send email type the password, please", cCaption)
  If s <> cPwd Then
    Cancel = True
    If s <> "" Then MsgBox "Wrong password!", vbExclamation, cCaption
  End If
 
End Sub

 

[Ahmad_0847]

Put this code into Outlook's module ThisOutlookSession and try to send email with/without forbidden words.

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
'ZVI:2017-11-23 https://www.mrexcel.com/forum/excel-questions/1032508-outlook-vba-code-ask-password-before-sending-email.html
 
  ' --> Settings, change to suit
  Const cPwd = "1234"             ' The password
  Const cWords = "Party,Treat"    ' Forbidden words in Subject or Body
  Const cCaption = "Email guard"  ' Caption of MsgBox
  ' <-- End of the settings
 
  ' Variables
  Dim s As String, sSubj As String, sBody As String, w
 
  ' Exit if it's not email
  If TypeName(Item) <> "MailItem" Then Exit Sub
 
  ' Don't send if forbidden word is in the Subject or Body
  sSubj = Item.Subject
  sBody = Item.BODY
  For Each w In Split(cWords, ",")
    s = Trim(w)
    If InStr(1, sSubj, s, vbTextCompare) > 0 Then s = "Subject": Exit For
    If InStr(1, sBody, s, vbTextCompare) > 0 Then s = "Body": Exit For
  Next
  If Len(w) > 0 Then
    Cancel = True
    MsgBox "Forbidden word found in the " & s & ":" & vbLf & w, vbExclamation, cCaption
    Exit Sub
  End If
 
  s = InputBox("To send email type the password, please", cCaption)
  If s <> cPwd Then
    Cancel = True
    If s <> "" Then MsgBox "Wrong password!", vbExclamation, cCaption
  End If
 
End Sub

Hi Vladimir,

Thanks for the code its also helpful for me. I was also finding the same from last one month.

Can you please suggest how we set password protection on created VBA on outlook, so no one can delete without password.