How to disable VBA macros from Outlook add-in? - vba

The following VBA macro is simply available as a against incorrect email transmission in Outlook365.
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim aExtAddrs() As String ' External Email Addresses
Dim iExtNum As Integer ' Number of those addresses
Dim olRecip
iExtNum = -1
For Each olRecip In Item.Recipients
If Not olRecip.Address Like "*#mydomain" Then
iExtNum = iExtNum + 1
ReDim Preserve aExtAddrs(iExtNum)
aExtAddrs(iExtNum) = olRecip.Address
End If
Next
If iExtNum < 0 Then Exit Sub
If MsgBox("Contains external email addresses. Are there any mistake ?" & vbCrLf & _
Join(vbCrLf, aExtAddrs), vbYesNo + vbQuestion, "Comfirmation") <> vbYes Then
Cancel = True ' Cancel to send
Exit Sub
End if
End Sub
So made this an add-in as it is.
Public Class ThisAddIn
Private Sub ThisAddIn_Startup() Handles Me.Startup
AddHandler Me.Application.ItemSend, AddressOf CatchItemSend
End Sub
Public Sub CatchItemSend(ByVal Item As Object, ByRef Cancel As Boolean)
Dim aExtAddrs() As String ' External Email Addresses
Dim iExtNum As Integer ' Number of those addresses
iExtNum = -1
For Each olRecip As Outlook.Recipient In Item.Recipients
If Not olRecip.Address Like "*#mydomain" Then
iExtNum = iExtNum + 1
ReDim Preserve aExtAddrs(iExtNum)
aExtAddrs(iExtNum) = olRecip.Address
End If
Next
If iExtNum < 0 Then Exit Sub
If MsgBox("Contains external email addresses. Are there any mistake ?" & vbCrLf & _
Join(vbCrLf, aExtAddrs), vbYesNo + vbQuestion, "Comfirmation") <> vbYes Then
Cancel = True ' Cancel to send
Exit Sub
End if
End Sub
End Class
In this case, if you don't remove the VBA macro when you install the add-in, the ItemSend event handler will be set twice and both will be called (simultaneously or sequentially). So I want to disable VBA macros, but I don't know how to do it properly. The simple thing is to manually remove the VBA macros when installing the add-in, but I don't want it, I want to do it automatically. What kind of method is possible?

Related

Determine if sending from specific mailbox

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

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

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

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