Outlook message box that asks to append subject line before sending

[Mikky]

Hello again Gurus :hi:

I posted a similar question back in February (sorry but I'm not allowed to post the link). Graham was able to help me out an I have been using the following code since:


Option Explicit

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim R As Outlook.Recipient
Dim olInsp As Outlook.Inspector
Dim wdDoc As Object
Dim oRng As Object
Const strCompany As String = " [COMPANY]"
Const sAddress As String = "insert email address here"
Const strText As String = "This text is added to the start of the message" & vbCr & vbNewLine
With Item
'this part should not be required as Outlook will warn of a missing subject
If Trim(.Subject) = "" Then
MsgBox "The subject is missing", vbInformation
Cancel = True
GoTo lbl_Exit
End If

'Add [COMPANY NAME] to Subject for all emails where that text doesn't already exist
If InStr(1, .Subject, strCompany) = 0 Then
.Subject = .Subject & strCompany
End If

'Send a BCC copy of every Email to yourself, change email address as required
Set R = .Recipients.Add(sAddress)
R.Type = olBCC
R.Resolve
'Add text to start of message
.Display
Set olInsp = .GetInspector
Set wdDoc = olInsp.WordEditor
Set oRng = wdDoc.Range(0, 0)
oRng.Text = strText
End With
lbl_Exit:
Exit Sub
End Sub

The issue is that I've now been asked to add a marker to the end of the subject line for selected emails (those of a personal nature). I've amended the code to include:


Const strPersonal As String = " [Personal]"

and


'Add [Personal] to Subject for all emails where that text doesn't already exist
If InStr(1, .Subject, strPersonal) = 0 Then
.Subject = .Subject & strPersonal
End If

But this change doesn't allow me to add the marker to selected emails – it adds it to all of them. What I need is a message box that asks if I want to add the marker and then append it if I select 'yes' or do nothing if I select 'no'. I tried modifying the above code myself but I ended up with too many IF statements.

Thanks for any help you can provide.

Cheers,
Mikky.

[gmayor]

If you want the subject to add either Company or Personal then


'Add [COMPANY NAME] to Subject for all emails where that text doesn't already exist
If MsgBox("Is the message personal?", vbYesNo) = vbYes Then
.Subject = .Subject & strPersonal
ElseIf InStr(1, .Subject, strCompany) = 0 Then
.Subject = .Subject & strCompany
End If

If you want to add personal and company then


'Add [COMPANY NAME] to Subject for all emails where that text doesn't already exist
If InStr(1, .Subject, strCompany) = 0 Then
.Subject = .Subject & strCompany
End If
If MsgBox("Is the message personal?", vbYesNo) = vbYes Then
.Subject = .Subject & strPersonal
End If

[Mikky]

Hi Graham

Thanks for your input - I used the second one you wrote and it works like a charm.

I only have one small issue. The code adds "Personal" (if I select "Yes") when I'm replying to an email as well. In the previous code we had a procedure to check if "Personal" was already in the subject line and if it was, then not add it again.

I've tried modifying what we have but I end up with too many If, Else and Then statements. Basically, I'm not VBA savvy :dunno

Is there a way to do this?

Thanks again,
Mikky.

[gmayor]

How about

If InStr(1, .Subject, strCompany) = 0 Then
.Subject = .Subject & strCompany
End If
If InStr(1, .Subject, strPersonal) = 0 Then
If MsgBox("Is the message personal?", vbYesNo) = vbYes Then
.Subject = .Subject & strPersonal
End If
End If

[Mikky]

Thanks Graham - worked a treat :joy:

I appreciate all your help.

Cheers, Mikky.