Outlook message box that asks to append subject line before sending

[Mikky]

Hello again Gurus

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

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

I appreciate all your help.

Cheers, Mikky.