Outlook VB Code Help - Reply All Prompt

I need some help to add an additional feature to my Outlook code. What I want is when a user clicks "No" after they hit "Reply-All" (The Code below prompts "Do you really want to reply to all original recipients?"), the only e-mail addresses they will be able to send to are internal domain e-mail addresses e.g. if they are working at company.com they will only be able to reply to @company.com e-mails. The code should strip any e-mails that are not internal before continuing the Reply-All.




Dim WithEvents colInsp As Outlook.Inspectors
 
Private Sub Application_Startup()
    Set colInsp = Application.Inspectors
End Sub
 
Private Sub colInsp_NewInspector(ByVal Inspector As Inspector)
    Dim msg As Outlook.MailItem
    Dim mymsg As String
    Dim myResult As Integer
    Dim count As Integer
    Dim i As Integer
    On Error Resume Next
 
    If TypeOf Inspector.CurrentItem Is Outlook.MailItem Then
 
        Set msg = Inspector.CurrentItem
        ' check if new item
        If msg.Size = 0 Then
            ' check if replyall
            If msg.Recipients.count > 1 Then
                mymsg = "Do you really want to reply to all original recipients?"
                myResult = MsgBox(mymsg, vbYesNo, "Flame Protector")
                If myResult = vbNo Then

THIS IS THE PART WHERE IT SHOULD CHECK THE TO/CC FIELDS AND REMOVE e-mails that has @company.com before continueing the reply-all


                End If
            End If
        End If
        Set msg = Nothing
    End If
End Sub
lineonecorpAsked:
Who is Participating?
 
Chris BottomleySoftware Quality Lead EngineerCommented:
Good point ... call me numpty for getting the wrong sense in re the current problem but at least it mightl stop some good entries being deleted.

For nothing to be deleted it could be colInsp_NewInspector, I would suspect the msg.Size = 0 as the issue ...try removing and make sure to run startup again.

In fact run application startup BEFORE you try disabling the size check ... but I would suspect the size as my greatest concern.


Chris
0
 
David LeeCommented:
Hi, lineonecorp.

Is the internal email on an Exchange server?  If so, then that introduces a problem.  Exchange doesn't use SMTP addresses internally.  It uses X.400 addresses.  That makes it a little more difficult, but not impossible, to check the addresses.  I just need to know which type of addressing to look for.
0
 
lineonecorpAuthor Commented:
Thanks for responding so quickly. Yes, the internal e-mail is an Exchange server.
0
Free Tool: ZipGrep

ZipGrep is a utility that can list and search zip (.war, .ear, .jar, etc) archives for text patterns, without the need to extract the archive's contents.

One of a set of tools we're offering as a way to say thank you for being a part of the community.

 
Chris BottomleySoftware Quality Lead EngineerCommented:
I would suggest that if you want to limit replies to internal recipients then the send event is better.  If you want to proceed as above then this can be done as follows:

Change the line to the required domain:

Const strCompany As String = "@company.com"

Chris
Private Sub colInsp_NewInspector(ByVal Inspector As Inspector)
    Dim msg As Outlook.MailItem
    Dim mymsg As String
    Dim myResult As Integer
    Dim count As Integer
    Dim i As Integer
Const strCompany As String = "@company.com"

    On Error Resume Next
 
    If TypeOf Inspector.CurrentItem Is Outlook.MailItem Then
 
        Set msg = Inspector.CurrentItem
        ' check if new item
        If msg.Size = 0 Then
            ' check if replyall
            If msg.Recipients.count > 1 Then
                mymsg = "Do you really want to reply to all original recipients?"
                myResult = MsgBox(mymsg, vbYesNo, "Flame Protector")
                If myResult = vbNo Then
Stop
                    For recip = msg.Recipients.count To 1 Step -1
                        If LCase(Right(msg.Recipients(recip).address, Len(strCompany))) = LCase(strCompany) Then msg.Recipients(recip).Delete
                        msg.Save
                    Next
'THIS IS THE PART WHERE IT SHOULD CHECK THE TO/CC FIELDS AND REMOVE e-mails that has @company.com before continueing the reply-all


                End If
            End If
        End If
        Set msg = Nothing
    End If
End Sub

Open in new window

0
 
Chris BottomleySoftware Quality Lead EngineerCommented:
Taking in teh exchange post then a slight mod as follows:

POst the code below in a new module and then in teh previous code change line 23:


                        If LCase(Right(GetSMTPAddress(msg.Recipients(recip).address), Len(strCompany))) = LCase(strCompany) Then msg.Recipients(recip).Delete
to

                        If LCase(Right(msg.Recipients(recip).address, Len(strCompany))) = LCase(strCompany) Then msg.Recipients(recip).Delete


Chris
Function GetSMTPAddress(ByVal strAddress As String)
' Based on:
' http://blogs.msdn.com/vikas/archive/2007/10/24/oom-getting-primary-smtp-address-from-x400-x500-sip-ccmail-etc.aspx
Dim olApp As Object
Dim oCon As Object
Dim strKey As String
Dim oRec As Object
Dim strRet As String
Dim fldr As Object
    
    If InStr(strAddress, "@") > 0 Then
        GetSMTPAddress = strAddress
    Else
        'IF OUTLOOK VERSION IS >= 2007 THEN USES NATIVE OOM PROPERTIES AND METHODS
        On Error Resume Next
        Set olApp = Application
        Set fldr = olApp.GetNamespace("MAPI").GetDefaultFolder(10).folders.Item("Random")
        If fldr Is Nothing Then
            olApp.GetNamespace("MAPI").GetDefaultFolder(10).folders.Add "Random"
            Set fldr = olApp.GetNamespace("MAPI").GetDefaultFolder(10).folders.Item("Random")
        End If
        On Error GoTo 0
        If CInt(Left(olApp.Version, 2)) >= 12 Then
            Set oRec = olApp.Session.CreateRecipient(strAddress)
            If oRec.Resolve Then
                strRet = oRec.AddressEntry.GetExchangeUser.PrimarySmtpAddress
            End If
        End If
        If Not strRet = "" Then GoTo ReturnValue
        'IF OUTLOOK VERSION IS < 2007 THEN USES LITTLE HACK
        'How it works
        '============
        '1) It will create a new contact item
        '2) Set it's email address to the value passed by you, it could be X500,X400 or any type of email address stored in the AD
        '3) We will assign a random key to this contact item and save it in its Fullname to search it later
        '4) Next we will save it to local contacts folder
        '5) Outlook will try to resolve the email address & make AD call if required else take the Primary SMTP address from its cache and append it to Display name
        '6) The display name will be something like this " ( email.address@server.com )"
        '7) Now we need to parse the Display name and delete the contact from contacts folder
        '8) Once the contact is deleted it will go to Deleted Items folder, after searching the contact using the unique random key generated in step 3
        '9) We then need to delete it from Deleted Items folder as well, to clean all the traces
        Set oCon = fldr.items.Add(2)
        oCon.Email1Address = strAddress
        strKey = "_" & Replace(Rnd * 100000 & Format(Now, "DDMMYYYYHmmss"), ".", "")
        oCon.FullName = strKey
        oCon.Save
        strRet = Trim(Replace(Replace(Replace(oCon.Email1DisplayName, "(", ""), ")", ""), strKey, ""))
        oCon.Delete
        Set oCon = Nothing
        Set oCon = olApp.Session.GetDefaultFolder(3).items.Find("[Subject]=" & strKey)
        If Not oCon Is Nothing Then oCon.Delete
ReturnValue:
        GetSMTPAddress = strRet
    End If
    
End Function

Open in new window

0
 
David LeeCommented:
This is what I had in mind.  This will handle both types.  You'd call it with like this

    StripExternal msg

There's another issue which hasn't been addressed: distribution lists.  The code as is won't work against a DL.  That means an external address in a DL will go through.  I'll have to look and see if there's a means of expanding a DL from code.  I don't remember off-hand if that's possible.  The code as is should strip out all standalone (i.e. not in a DL) external addresses, both SMTP and Exchange.

To help you find your X.400 mail domain I've included a routine called DisplayX400.  To use it

1.  Create an email and address it to yourself
2.  Run DisplayX400
3.  Note done the /O=Some_Name portion

You'll need that to edit the main routine.
Sub StripExternal(olkMsg As Outlook.MailItem)
    'On the next line edit the email domain'
    Const INTERNAL_DOMAIN = "@company.com"
    'On the next line edit the X.400 email domain'
    Const INTERNAL_X400 = "/O=company"
    Dim olkRcp As Outlook.Recipient, intIndex As Integer
    olkMsg.Recipients.ResolveAll
    For intIndex = olkMsg.Recipients.Count To 1 Step -1
        Set olkRcp = olkMsg.Recipients.Item(intIndex)
        Select Case olkRcp.AddressEntry.AddressEntryUserType
            Case olSmtpAddressEntry
                If InStr(1, LCase(olkRcp.Address), INTERNAL_DOMAIN) = 0 Then
                    olkMsg.Recipients.Item(intIndex).Delete
                End If
            Case olExchangeUserAddressEntry
                If InStr(1, olkRcp.Address, INTERNAL_X400) = 0 Then
                    olkMsg.Recipients.Item(intIndex).Delete
                End If
            Case olExchangeDistributionListAddressEntry, olOutlookDistributionListAddressEntry
            Case Else
                MsgBox "The message contains an unusual address type that cannot be processed.", vbExclamation + vbOKOnly, "Strip External"
        End Select
    Next
End Sub

Sub DisplayX400()
    Dim olkMsg As Outlook.MailItem, olkRcp As Outlook.Recipient
    Set olkMsg = Application.ActiveInspector.CurrentItem
    olkMsg.Recipients.ResolveAll
    For Each olkRcp In olkMsg.Recipients
        MsgBox olkRcp.Address
    Next
    Set olkMsg = Nothing
    Set olkRcp = Nothing
End Sub

Open in new window

0
 
lineonecorpAuthor Commented:
Hi Blue,

Would I add the code you posted above into a module and modify the code to look like this:


Dim WithEvents colInsp As Outlook.Inspectors
 
Private Sub Application_Startup()
    Set colInsp = Application.Inspectors
End Sub
 
Private Sub colInsp_NewInspector(ByVal Inspector As Inspector)
    Dim msg As Outlook.MailItem
    Dim mymsg As String
    Dim myResult As Integer
    Dim count As Integer
    Dim i As Integer

    On Error Resume Next
 
    If TypeOf Inspector.CurrentItem Is Outlook.MailItem Then
 
        Set msg = Inspector.CurrentItem
        ' check if new item
        If msg.Size = 0 Then
            ' check if replyall
            If msg.Recipients.count > 1 Then
                mymsg = "Do you really want to reply to all original recipients?"
                myResult = MsgBox(mymsg, vbYesNo, "Flame Protector")
                If myResult = vbNo Then
                       
                    StripExternal msg

                End If
            End If
        End If
        Set msg = Nothing
    End If
End Sub

0
 
David LeeCommented:
Yes.
0
 
lineonecorpAuthor Commented:
Thanks, I will give it a try and let you know how it goes.
0
 
lineonecorpAuthor Commented:
I modified the internal domain address and x400 address per your notes in the module. When I click "Reply-All" the prompt comes up: "Do you really want to reply to all original recipients?". I click No and it continues the message which is great but it still won't remove the external domain addresses. I also disabled macro security to make sure it's not blocking anything. Any suggestions?
0
 
David LeeCommented:
I tested before posting and the code did always remove addresses where the domain (X400 and SMTP) did not match the values in the code.  Are you familiar with using the debugger?
0
 
Chris BottomleySoftware Quality Lead EngineerCommented:
NOT FOR POINTS

Just wondering if it's case so removed case sensitivity ... does it help?

Chris
Sub StripExternal(olkMsg As Outlook.MailItem)
    'On the next line edit the email domain'
    Const INTERNAL_DOMAIN = "@company.com"
    'On the next line edit the X.400 email domain'
    Const INTERNAL_X400 = "/O=company"
    Dim olkRcp As Outlook.Recipient, intIndex As Integer
    olkMsg.Recipients.ResolveAll
    For intIndex = olkMsg.Recipients.Count To 1 Step -1
        Set olkRcp = olkMsg.Recipients.Item(intIndex)
        Select Case olkRcp.AddressEntry.AddressEntryUserType
            Case olSmtpAddressEntry
                If InStr(1, LCase(olkRcp.Address), INTERNAL_DOMAIN, vbTextCompare) = 0 Then
                    olkMsg.Recipients.Item(intIndex).Delete
                End If
            Case olExchangeUserAddressEntry
                If InStr(1, olkRcp.Address, INTERNAL_X400, vbTextCompare) = 0 Then
                    olkMsg.Recipients.Item(intIndex).Delete
                End If
            Case olExchangeDistributionListAddressEntry, olOutlookDistributionListAddressEntry
            Case Else
                MsgBox "The message contains an unusual address type that cannot be processed.", vbExclamation + vbOKOnly, "Strip External"
        End Select
    Next
End Sub

Open in new window

0
 
David LeeCommented:
Good point, Chris.  I made one of them case sensitive, but not both.  A case mismatch should cause all addresses to be removed.  The logic is to remove anything that doesn't match the specified domains.  Since nothing is being removed, it sounds like the code is matching the domain to something it sees in the address.  Maybe a partial match?
0
 
lineonecorpAuthor Commented:
Still won't remove the external addresses. Here is the code I am using:

Module:

Sub StripExternal(olkMsg As Outlook.MailItem)
    'On the next line edit the email domain'
    Const INTERNAL_DOMAIN = "@mydomain.com"
    'On the next line edit the X.400 email domain'
    Const INTERNAL_X400 = "/O=DOMAIN1"
    Dim olkRcp As Outlook.Recipient, intIndex As Integer
    olkMsg.Recipients.ResolveAll
    For intIndex = olkMsg.Recipients.count To 1 Step -1
        Set olkRcp = olkMsg.Recipients.Item(intIndex)
        Select Case olkRcp.AddressEntry.AddressEntryUserType
            Case olSmtpAddressEntry
                If InStr(1, LCase(olkRcp.Address), INTERNAL_DOMAIN, vbTextCompare) = 0 Then
                    olkMsg.Recipients.Item(intIndex).Delete
                End If
            Case olExchangeUserAddressEntry
                If InStr(1, olkRcp.Address, INTERNAL_X400, vbTextCompare) = 0 Then
                    olkMsg.Recipients.Item(intIndex).Delete
                End If
            Case olExchangeDistributionListAddressEntry, olOutlookDistributionListAddressEntry
            Case Else
                MsgBox "The message contains an unusual address type that cannot be processed.", vbExclamation + vbOKOnly, "Strip External"
        End Select
    Next
End Sub

Sub DisplayX400()
    Dim olkMsg As Outlook.MailItem, olkRcp As Outlook.Recipient
    Set olkMsg = Application.ActiveInspector.CurrentItem
    olkMsg.Recipients.ResolveAll
    For Each olkRcp In olkMsg.Recipients
        MsgBox olkRcp.Address
    Next
    Set olkMsg = Nothing
    Set olkRcp = Nothing
End Sub




ThisOutlookSession Code:

Dim WithEvents colInsp As Outlook.Inspectors
 
Private Sub Application_Startup()
    Set colInsp = Application.Inspectors
End Sub
 
Private Sub colInsp_NewInspector(ByVal Inspector As Inspector)
    Dim msg As Outlook.MailItem
    Dim mymsg As String
    Dim myResult As Integer
    Dim count As Integer
    Dim i As Integer

    On Error Resume Next
 
    If TypeOf Inspector.CurrentItem Is Outlook.MailItem Then
 
        Set msg = Inspector.CurrentItem
        ' check if new item
        If msg.Size = 0 Then
            ' check if replyall
            If msg.Recipients.count > 1 Then
                mymsg = "Do you really want to reply to all original recipients?"
                myResult = MsgBox(mymsg, vbYesNo, "Flame Protector")
                If myResult = vbNo Then
                       
                    StripExternal msg

                End If
            End If
        End If
        Set msg = Nothing
    End If
End Sub



0
 
David LeeCommented:
Do you know how to use the debugger in Outlook?  If so, then you can set a couple of breakpoints that will allow us to see what's happening.
0
 
David LeeCommented:
Definitely.  That's a good catch.  We need to fix it to prevent good entries from being removed.  

If we can set a couple of breakpoints, then we can see if the code is even firing.  It may not be.
0
 
lineonecorpAuthor Commented:
There's a run time error 91 under Sub DisplayX400() for "Set olkMsg = Application.ActiveInspector.CurrentItem"
0
 
lineonecorpAuthor Commented:
438 error under Sub StripExternal for "Select Case olkRcp.AddressEntry.AddressEntryUserType"
0
 
David LeeCommented:
There must be an open mail item before DisplayX400 will work.

Remind me of what version of Outlook you're using?
0
 
lineonecorpAuthor Commented:
I'm testing the code with Outlook 2000/Exchange 2000 but it will eventually be used in Outlook 2007/Outlook2010/Exchange 2003
0
 
David LeeCommented:
It probably won't work on 2000.  Need to test it on 2007 or 2010.  There are major differences in Outlook's object model between 2000 and 2007.  The version of Exchange shouldn't make any difference.
0
 
lineonecorpAuthor Commented:
I tried with Outlook 2010/Exchange 2010 and it didn't give the error but when I hit "No" it strips ALL e-mails internal and external.
0
 
David LeeCommented:
Ok, that would be the case mismatch that Chris pointed out.  Did you implement the code change he suggested?  If not, then please do so.  It's the code from this post: 35335456
0
 
lineonecorpAuthor Commented:
Yes I did
0
 
David LeeCommented:
Then we're back to needing to do a little debugging.
0
 
lineonecorpAuthor Commented:
The OTM looks like this:

Dim WithEvents colInsp As Outlook.Inspectors
 
Private Sub Application_Startup()
    Set colInsp = Application.Inspectors
End Sub
 
Private Sub colInsp_NewInspector(ByVal Inspector As Inspector)
    Dim msg As Outlook.MailItem
    Dim mymsg As String
    Dim myResult As Integer
    Dim count As Integer
    Dim i As Integer

    'On Error Resume Next
 
    If TypeOf Inspector.CurrentItem Is Outlook.MailItem Then
 
        Set msg = Inspector.CurrentItem
        ' check if new item
        If msg.Size = 0 Then
            ' check if replyall
            If msg.Recipients.count > 1 Then
                mymsg = "Do you really want to reply to all original recipients?"
                myResult = MsgBox(mymsg, vbYesNo, "Flame Protector")
                If myResult = vbNo Then
                       
                    StripExternal msg

                End If
            End If
        End If
        Set msg = Nothing
    End If
End Sub




Did you want me to remove the "If msg.Size = 0 Then" part?
0
 
lineonecorpAuthor Commented:
The StripExternal is definately firing because it shows all the external addresses when I run put a break at " If InStr(1, olkRcp.Address, INTERNAL_X400, vbTextCompare) = 0 Then"
0
 
David LeeCommented:
Are the external addresses listed in your GAL?
0
 
lineonecorpAuthor Commented:
It seems to be working now. What's the best way to install it on multiple computers without having them copy and paste the code into VB and change macro settings? Is it possible to just send them a VBS script that they just run once and it does it for them?
0
 
David LeeCommented:
No, that's not possible.  Outlook does not have any automated means of installing macros or adding code.  The only solution for distributing macro code is to copy Outlook's code file to each computer.  The problem with this is that it will overwrite any code already in Outlook causing it be lost.  Of course if there is no code in Outlook, then this solution works well.  If there is, then the people who lost code are likely to be unhappy.

The file you need to copy is VbaProject.OTM.  It's location varies depending on which version of Windows is in use.  On a Windows 7 machine the path is

c:\Users\<username>\AppData\Roaming\Microsoft\Outlook\
0
 
lineonecorpAuthor Commented:
Got it. Thanks to all  for all the work.
0
 
David LeeCommented:
Collaboration is a great thing.
0
 
PLA_LTMCommented:
This is a Great!!

I personally use this but got a request from a user to only enable this if there is at least one external email address present.

Is there a tweak that will only display the "Do you really want to reply to all original recipients?"  if there is a non-company.com address found?

for all internal reply-all's this message should not appear.
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.