Automatically appending a suffix to Email recipient's address

I'm assuming you want that suffix added to every address for every message.  Is that correct?  If so, would you like that to happen as you send messages?

Thank you for your participation.  Yes, the suffix would be added to every address for every message, as the message is being sent.  However, I'd like to activate this process with a rule, so that it could be turned off in some instances.

It is not possible to do this with a rule.  It requires a script.  I can write the script so you can enable/disable it with a single click.  Will that work?

A script which always adds the suffix by default, but can be disabled or re-enabled with a single click would seem workable.

Here's the code.  Follow these instructions to add it to Outlook.

1.  Copy the code below and paste into the ThisOutlookSession module in Outlook.
2.  Choose one of the methods from this page for adding a button that runs a macro.  Set the button to run the macro named ToggleAddSuffix.  Clicking the button will flip the option to add the suffix on and off.  When it's on, the code in Application_ItemSend will add the suffix to all addresses of any email you send.  

Dim bolAddSuffix As Boolean

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
    Dim olkRcp As Outlook.RECIPIENT, olkNew As Outlook.RECIPIENT, intCnt As Integer
    If bolAddSuffix Then
        If Item.Class = olMail Then
            For intCnt = Item.Recipients.Count To 1 Step -1
                Set olkRcp = Item.Recipients.Item(intCnt)
                Set olkNew = Session.CreateRecipient(olkRcp.Address & ".WhoReadMe.com")
                olkNew.Resolve
                olkRcp.Delete
                Item.Recipients.Add olkNew
            Next
            Item.Save
        End If
    End If
End Sub

Sub ToggleAddSuffix()
    bolAddSuffix = Not boAddSuffix
    MsgBox "AddSuffix is now " & IIF(bolAddSuffix, "ON", "OFF"), vbInformation+vbOkOnly, "Toggle Add Suffix"
End Sub

Select allOpen in new window

Thank you!
Testing this code, I'm having a couple of challenges...

1. The toggle button on the tool bar doesn't turn suffix off.  Every click of the button produces the message "AddSuffix is now ON.";

2. Right-clicking the toolbar button, there is no option to rename it.

3. The suffix is added to outgoing messages, but the messages are not delivered:

"Your message did not reach some or all of the intended recipients.
      Subject:      WRM suffix5
      Sent:      2/25/2014 11:56 AM
The following recipient(s) cannot be reached:"

If I add the suffix manually, the message is delivered.
I've attached a screen shot of ThisOutlookSession.
Image2.jpg

1. The toggle button on the tool bar doesn't turn suffix off.  Every click of the button produces the message "AddSuffix is now ON.";

 There's a typo on line #20 of the code.  Line 20 should read

bolAddSuffix = Not bolAddSuffix

Select allOpen in new window

2. Right-clicking the toolbar button, there is no option to rename it.

I don't know which method you chose for adding the button, so I'm not clear on the problem is or how to fix it.

3. The suffix is added to outgoing messages, but the messages are not delivered:

Did I add the suffix correctly?  Take a look at a sent message to see if I got it right.  If I did get it right and the messages aren't being delivered, then I don't have an answer.  If I got it wrong, then tell me how it's wrong and I'll fix it.

Thank you.  Correcting the typo allows the function to be toggled.
The correct suffix is added.  If I toggle the automatic suffix OFF, and insert an identical suffix manually, it is delivered without that Administrative message.

I believe there could be an issue with how the recipient's address is inserted into the outgoing message.  If I compare a failed message with automatic suffix to a successful message with manual suffix, there is a difference:  double-clicking the recipient's address in the successful message opens up a dialog box "Email Properties".  Double-clicking the recipient's address in the failed message does not open anything.  I'm attaching both messages, hoping your examination will be helpful.manualsuffix.msgautosuffix.msg

The method used for adding a macro button to the tool bar was Customize>Macros, then drag the macro onto the tool bar.

I looked at the properties of both messages.  The recipient on the autosuffix message doesn't have an email address while the recipient in the manualsuffix message does.  That's odd.  I tested the code again and on my computer the address is filled in properly.  I'm at a bit of a loss to understand why it isn't on your computer.  The best I can figure is that on your computer Outlook hasn't resolved the address by the time the code runs.  It should have, and it does on my computer, but the evidence suggest that it hasn't on your computer.  Assuming that's the problem, then adding this line of code

olkRcp.Resolve

Select allOpen in new window

immediately after line #8 of the code in my earlier post should fix that problem.  Please give that a try ad let me know if that does it.

Thank you.  I inserted the new line of a code as a new line, after line #8.  Unfortunately, the behavior is the same.

Then I'm stumped. I don't use the service, so I can't do a live test. The closest I can come is to go through the motions and stop the message before it leaves my outbox. Everything looks right at that point. I don't know what's happening after that.

I don't think this is related to the service.  The message from Administrator appears less than one second after sending the message.  It says the message could not be delivered to the following recipients, and that field is blank.  I tried replacing ".whoreadme.com" with "", so the message was sent without a suffix.  Same undeliverable error.

On a positive note, I found out how to rename the macro button on the toolbar.

It sounds like the address is disappearing somehow.  I don't know why that would happen or what could cause it.  Do you have any Outlook add-ins installed or any other code that affects outbound messages?

I have some Outlook add-ins.  However, adding the suffix manually doesn't interfere with delivery.  I disabled all the add-ins except for Microsoft VBA for Outlook, which is required to run your script, and it didn't make a difference.

There are other scripts running in Outlook, including one which you provided, in response to another EE question.   I tried removing everything in ThisOutlookSession except for AddSuffix, and everything in two additional Modules, and it didn't make any difference.

However, adding the suffix manually doesn't interfere with delivery.

Yes, but you're entering that manually.  Something is happening when the code tries to modify the addresses.  I was hedging against the possibility that some other add-in or macro was interfering with the add suffix code.

The only thing left to do is to try some debugging to try and figure out what's happening and why.  

1.  Replace the code you have now with the version below.  
2.  Turn AddSuffix on
3.  Create a new email
4.  Address it to one address
5.  Send the message
6.  Switch back to the VB editor
7.  If the "Immediate" pane is not opened, then open it by pressing CTRL+G
8.  The "Immediate" pane should contain some output that looks like this

AddSuffix is turned on
The item is an email.
Recipient #1
Old Address: bugs@looneytunes.com
New Address: bugs@looneytunes.com.WhoReadMe.com

9.  Paste the results in your response.

Dim bolAddSuffix As Boolean

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
    Dim olkRcp As Outlook.RECIPIENT, olkNew As Outlook.RECIPIENT, intCnt As Integer
    If bolAddSuffix Then
        Debug.Print "AddSuffix is turned on"
        If Item.Class = olMail Then
            Debug.Print "The item is an email."
            For intCnt = Item.Recipients.Count To 1 Step -1
                Debug.Print "Recipient #" & intCnt
                Set olkRcp = Item.Recipients.Item(intCnt)
                olkRcp.Resolve
                Debug.Print "Old Address: " & olkRcp.Address
                Set olkNew = Session.CreateRecipient(olkRcp.Address & ".WhoReadMe.com")
                olkNew.Resolve
                Debug.Print "New Address: " & olkNew.Address
                olkRcp.Delete
                Item.Recipients.Add olkNew
            Next
            Item.Save
        End If
    End If
End Sub

Sub ToggleAddSuffix()
    bolAddSuffix = Not bolAddSuffix
    MsgBox "AddSuffix is now " & IIf(bolAddSuffix, "ON", "OFF"), vbInformation + vbOKOnly, "Toggle Add Suffix"
End Sub

Select allOpen in new window

Thank you for the debug script.  The "undeliverable" notice appeared.  Here are the contents of the "immediate" pane:

The item is an email.
Recipient #1
Old Address: ddantes@compuserve.com
New Address: ddantes@compuserve.com.WhoReadMe.com

I have four machines in my office -- two desktops running Outlook 2007 on Windows 7 and two notebooks running Outlook 2007 on Windows XP.  I've tried the script on all of them, but no joy.  Both Windows 7 machines have the "undelivered" message.  Both Windows XP machines go into a state where the send/receive progress window appears to be vibrating, and the number of "completed tasks" continuously increases, into the triple digits, until I close Outlook.

That worked totally!   Thank you for your perseverance.

I have a request for a possible refinement to this code.  If you're available to look at it, please see

https://www.experts-exchange.com/questions/28375379/Avoiding-insertion-of-a-redundant-suffix-to-recipient's-Email.html

You're welcome.  Sorry it took me so long to figure it out.

I'll go have a look at your new question.