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