Outlook message box that asks to append subject line before sending

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:

Code:

---

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:

Code:

---

Const strPersonal As String = " [Personal]"

---

and

Code:

---

'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.

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

Code:

---

        '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

Code:

---

        '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

---

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.

How about

Code:

---

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

---

Thanks Graham - worked a treat :joy:

I appreciate all your help.

Cheers, Mikky.