Outlook code To names need to detect even if after the first TO can be in any range in TO.

Hi,

Outlook code To names need to detect even if after the first TO can be in any range in TO.
The below code does not work when i reply to a mail even when i reply and a user is in the TO or CC i want the others to be added into CC.

Say Frank sends a mail to me and i add Jerald into CC or To. When sent i want 2 more names to be added in CC because Jerald is there in To or CC.

the below code is from Chris

Regards
Sharath
Regards
Sharath
Sub toMe(mai As mailitem)
'Const Your_email_Addy As String = "smith, fred" ' DISPLAYED NAME!
Dim olkRecip As Object
Dim special As Variant
Dim index1 As Integer
Dim index2 As Integer
Dim sendto As String
Dim addr As Variant
Const special1 As String = "lookforaddress, fred1@fred.com, fred2@fred.com"
Const special2 As String = ""
Const special3 As String = ""
Const special4 As String = ""
Const special5 As String = ""
Const special6 As String = ""
 
    special = Array(Split(special1, ", "), _
    Split(special2, ", "), _
    Split(special3, ", "), _
    Split(special4, ", "), _
    Split(special5, ", "), _
    Split(special6, ", "))
    
    For index1 = 0 To 5
        sendto = ""
        If UBound(special(index1)) < 1 Then Exit For
        For index2 = 1 To 6
            If UBound(special(index1)) >= index2 Then
                If sendto <> "" Then sendto = sendto & ", "
                If special(index1)(index2) <> "" Then sendto = sendto & special(index1)(index2)
            End If
        Next
        debug.print LCase(mai.Recipients(1).Name) & " = " & LCase(special(index1)(0)) & "? .... " & LCase(mai.Recipients(1).Name) = LCase(special(index1)(0))
        If LCase(mai.Recipients(1).Name) = LCase(special(index1)(0)) Then
            If MsgBox("Append the common CC names" & vbCrLf & vbCrLf & sendto & "?", vbYesNo, "Append common recipients") = vbYes Then
                For Each addr In Split(sendto, ", ")
                    Set olkRecip = mai.Recipients.Add(addr)
                    olkRecip.Type = olCC
                Next
            End If
            mai.Recipients.ResolveAll
        End If
    Next
 
End Sub

Open in new window

LVL 11
bsharathAsked:
Who is Participating?
 
Chris BottomleySoftware Quality Lead EngineerCommented:
Assuming I am correct and it resolves the problem then the tidied code is as follows:

Chris
Sub toMe(mai As mailitem)
Dim olkRecip As Object
Dim olkTORecip As Object
Dim special As Variant
Dim index1 As Integer
Dim index2 As Integer
Dim sendto As String
Dim addr As Variant
Const special1 As String = "fred smith, fred@fred.com"
Const special2 As String = ""
Const special3 As String = ""
Const special4 As String = ""
Const special5 As String = ""
Const special6 As String = ""
 
    special = Array(Split(Replace(Replace(special1, ",", ", "), "  ", " "), ", "), _
    Split(Replace(Replace(special2, ",", ", "), "  ", " "), ", "), _
    Split(Replace(Replace(special3, ",", ", "), "  ", " "), ", "), _
    Split(Replace(Replace(special4, ",", ", "), "  ", " "), ", "), _
    Split(Replace(Replace(special5, ",", ", "), "  ", " "), ", "), _
    Split(Replace(Replace(special6, ",", ", "), "  ", " "), ", "))
    
    For index1 = 0 To 5
        sendto = ""
        If UBound(special(index1)) < 1 Then Exit For
        For index2 = 1 To 6
            If UBound(special(index1)) >= index2 Then
                If sendto <> "" Then sendto = sendto & ", "
                If special(index1)(index2) <> "" Then sendto = sendto & special(index1)(index2)
            End If
        Next
        For Each olkTORecip In mai.Recipients
            If olkTORecip.Type = olTo Then
                If LCase(olkTORecip.Name) = LCase(special(index1)(0)) Then
                    If MsgBox("Append the common CC names" & vbCrLf & vbCrLf & sendto & "?", vbYesNo, "Append common recipients") = vbYes Then
                        For Each addr In Split(sendto, ", ")
                            Set olkRecip = mai.Recipients.Add(addr)
                            olkRecip.Type = olCC
                        Next
                    End If
                    mai.Recipients.ResolveAll
                End If
            End If
        Next
    Next
 
End Sub

Open in new window

0
 
Chris BottomleySoftware Quality Lead EngineerCommented:
Hmmm.

First let me try to ensure I understand the request:

1. Originally teh request to add CC names to the recipients was triggered by the selection of the first recipient .

Are you saying the change is to go through all the 'to' recipients and offer to add all the CC contacts related to the collected TO recipients?

Chris
0
 
bsharathAuthor Commented:
Yes exactly
0
Ultimate Tool Kit for Technology Solution Provider

Broken down into practical pointers and step-by-step instructions, the IT Service Excellence Tool Kit delivers expert advice for technology solution providers. Get your free copy now.

 
Chris BottomleySoftware Quality Lead EngineerCommented:
OKay

The following cycles through each to addressee and offers to add the CC for each in turn.  See how it looks and let me know.

Chris
Sub toMe(mai As mailitem)
'Dim mai As mailitem
Const Your_email_Addy As String = "smith, fred" ' DISPLAYED NAME!
Dim olkRecip As Object
Dim olkTORecip As Object
Dim special As Variant
Dim index1 As Integer
Dim index2 As Integer
Dim sendto As String
Dim addr As Variant
Const special1 As String = "lookforaddress, fred1@fred.com, fred2@fred.com"
Const special2 As String = ""
Const special3 As String = ""
Const special4 As String = ""
Const special5 As String = ""
Const special6 As String = ""
 
    special = Array(Split(special1, ", "), _
    Split(special2, ", "), _
    Split(special3, ", "), _
    Split(special4, ", "), _
    Split(special5, ", "), _
    Split(special6, ", "))
    
    For index1 = 0 To 5
        sendto = ""
        If UBound(special(index1)) < 2 Then Exit For
        For index2 = 1 To 6
            If UBound(special(index1)) >= index2 Then
                If sendto <> "" Then sendto = sendto & ", "
                If special(index1)(index2) <> "" Then sendto = sendto & special(index1)(index2)
            End If
        Next
        For Each olkTORecip In mai.Recipients
            If olkTORecip.Type = olTo Then
                If LCase(olkTORecip.Name) = LCase(special(index1)(0)) Then
                    If MsgBox("Append the common CC names" & vbCrLf & vbCrLf & sendto & "?", vbYesNo, "Append common recipients") = vbYes Then
                        For Each addr In Split(sendto, ", ")
                            Set olkRecip = mai.Recipients.Add(addr)
                            olkRecip.Type = olCC
                        Next
                    End If
                    mai.Recipients.ResolveAll
                End If
            End If
        Next
    Next
 
End Sub

Open in new window

0
 
bsharathAuthor Commented:
Chris its not triggering when mail sent.
I dont get the box
0
 
bsharathAuthor Commented:
Chris its not triggering when mail sent.
I dont get the box
0
 
Chris BottomleySoftware Quality Lead EngineerCommented:
Overall the functionality is as before ... I hope therefore are you sure the correct data is in the special1-6 arrays and that each item is seperated by comma space?

Chris
0
 
bsharathAuthor Commented:
Yes they are right
The only change i am doing in the code is this

Const special1 As String = "Sharath yui, Sharath.yui@plc.com"
0
 
bsharathAuthor Commented:
Yes they are right
The only change i am doing in the code is this

Const special1 As String = "Sharath yui, Sharath.yui@plc.com"
0
 
Chris BottomleySoftware Quality Lead EngineerCommented:
Added the debug for name comparisons

WHat does the debug trace suggest?

Chris
Sub toMe(mai As mailitem)
'Dim mai As mailitem
Const Your_email_Addy As String = "smith, fred" ' DISPLAYED NAME!
Dim olkRecip As Object
Dim olkTORecip As Object
Dim special As Variant
Dim index1 As Integer
Dim index2 As Integer
Dim sendto As String
Dim addr As Variant
Const special1 As String = "lookforaddress, fred1@fred.com, fred2@fred.com"
Const special2 As String = ""
Const special3 As String = ""
Const special4 As String = ""
Const special5 As String = ""
Const special6 As String = ""
 
    special = Array(Split(special1, ", "), _
    Split(special2, ", "), _
    Split(special3, ", "), _
    Split(special4, ", "), _
    Split(special5, ", "), _
    Split(special6, ", "))
    
    For index1 = 0 To 5
        sendto = ""
        If UBound(special(index1)) < 2 Then Exit For
        For index2 = 1 To 6
            If UBound(special(index1)) >= index2 Then
                If sendto <> "" Then sendto = sendto & ", "
                If special(index1)(index2) <> "" Then sendto = sendto & special(index1)(index2)
            End If
        Next
        For Each olkTORecip In mai.Recipients
        debug.print LCase(olkTORecip.Name) & " = " & LCase(special(index1)(0)) & "? .... " & LCase(olkTORecip.Name) = LCase(special(index1)(0))
            If olkTORecip.Type = olTo Then
                If LCase(olkTORecip.Name) = LCase(special(index1)(0)) Then
                    If MsgBox("Append the common CC names" & vbCrLf & vbCrLf & sendto & "?", vbYesNo, "Append common recipients") = vbYes Then
                        For Each addr In Split(sendto, ", ")
                            Set olkRecip = mai.Recipients.Add(addr)
                            olkRecip.Type = olCC
                        Next
                    End If
                    mai.Recipients.ResolveAll
                End If
            End If
        Next
    Next
 
End Sub

Open in new window

0
 
bsharathAuthor Commented:
>>WHat does the debug trace suggest?
How can i check it...
0
 
bsharathAuthor Commented:
>>WHat does the debug trace suggest?
How can i check it...
0
 
Chris BottomleySoftware Quality Lead EngineerCommented:
recipient name being checked in teh mail     Name being looked for from teh array          Are they equal

Presumably they are all showing false at the end but some of the recipient name being checked should equal the Name being looked for first element of each of the six special arrays.

Essentially your name being looked for needs to match the array 0 element where appropriate therefore look for an entry in the start of the row that should appear in teh array and see where it enterered wrong in the array and change those first entries in the array accordingly.

Chris
0
 
bsharathAuthor Commented:
Yes they are the same as befor.
I just took the names from the previous code and replaced.

Even the TO is in the first i dont get the popup
0
 
Chris BottomleySoftware Quality Lead EngineerCommented:
Dou you see match in the names printed out.  I am especially suggesting you then look at the true false and if it is false look further into spaces or the like to see why they might be seen as different.

If for example you can then send me an example of debug where the names match yet the boolean says false.

Chris
0
 
bsharathAuthor Commented:
There is no name printed out
Is there anything i need to put in immediate windo to get a result.
I dont get False any where
0
 
bsharathAuthor Commented:
There is no name printed out
Is there anything i need to put in immediate windo to get a result.
I dont get False any where
0
 
Chris BottomleySoftware Quality Lead EngineerCommented:
The structure for the output string was flawed ... fixed here.

I have also inserted a change to hopefully force the array initialisation to be correct for the analysis that follows.  It still works for me but just maybe your data structure was in error and if so this could be the fix you need.

Chris
Sub toMe(mai As mailitem)
'Dim mai As mailitem
Const Your_email_Addy As String = "smith, fred" ' DISPLAYED NAME!
Dim olkRecip As Object
Dim olkTORecip As Object
Dim special As Variant
Dim index1 As Integer
Dim index2 As Integer
Dim sendto As String
Dim addr As Variant
Const special1 As String = "dadt@rose-isle.net,fred1@pc-development.com,   fred2@pc-development.com"
Const special2 As String = ""
Const special3 As String = ""
Const special4 As String = ""
Const special5 As String = ""
Const special6 As String = ""
 
    special = Array(Split(Replace(Replace(special1, " ", ""), ",", ", "), ", "), _
    Split(Replace(Replace(special2, " ", ""), ",", ", "), ", "), _
    Split(Replace(Replace(special3, " ", ""), ",", ", "), ", "), _
    Split(Replace(Replace(special4, " ", ""), ",", ", "), ", "), _
    Split(Replace(Replace(special5, " ", ""), ",", ", "), ", "), _
    Split(Replace(Replace(special6, " ", ""), ",", ", "), ", "))
    
    For index1 = 0 To 5
        sendto = ""
        If UBound(special(index1)) < 2 Then Exit For
        For index2 = 1 To 6
            If UBound(special(index1)) >= index2 Then
                If sendto <> "" Then sendto = sendto & ", "
                If special(index1)(index2) <> "" Then sendto = sendto & special(index1)(index2)
            End If
        Next
        For Each olkTORecip In mai.Recipients
            Debug.Print LCase(olkTORecip.Name) & " = " & LCase(special(index1)(0)) & "? .... " & CStr(LCase(olkTORecip.Name) = LCase(special(index1)(0)))
            If olkTORecip.Type = olTo Then
                If LCase(olkTORecip.Name) = LCase(special(index1)(0)) Then
                    If MsgBox("Append the common CC names" & vbCrLf & vbCrLf & sendto & "?", vbYesNo, "Append common recipients") = vbYes Then
                        For Each addr In Split(sendto, ", ")
                            Set olkRecip = mai.Recipients.Add(addr)
                            olkRecip.Type = olCC
                        Next
                    End If
                    mai.Recipients.ResolveAll
                End If
            End If
        Next
    Next
 
End Sub

Open in new window

0
 
bsharathAuthor Commented:
Still dont get a popup that asks me nor any data in the immediate window that tell what happened
0
 
bsharathAuthor Commented:
Still dont get a popup that asks me nor any data in the immediate window that tell what happened
0
 
Chris BottomleySoftware Quality Lead EngineerCommented:
You are still calling the sub from the thisoutlookapplication Application_ItemSend sub aren't you?

Chris
0
 
bsharathAuthor Commented:
yes i have this

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
    toMe Item
 End Sub
0
 
Chris BottomleySoftware Quality Lead EngineerCommented:
CAnt avoid it now you need to diagnose ...

Modify:

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
    toMe Item
 End Sub

to

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
    stop
    toMe Item
 End Sub

Send an email that should trigger the additions and pressing F8 each time see what the macro does where it steps and what the data is at each stage

Chris
0
 
bsharathAuthor Commented:
After the 2nd F8 it goes here
special = Array(Split(Replace(Replace(special1, " ", ""), ",", ", "), ", "), _
    Split(Replace(Replace(special2, " ", ""), ",", ", "), ", "), _
    Split(Replace(Replace(special3, " ", ""), ",", ", "), ", "), _
    Split(Replace(Replace(special4, " ", ""), ",", ", "), ", "), _
    Split(Replace(Replace(special5, " ", ""), ",", ", "), ", "), _
    Split(Replace(Replace(special6, " ", ""), ",", ", "), ", "))
Then goes next next then
goes
Exit For
then
end sub
and finishes sending the email
0
 
bsharathAuthor Commented:
After the 2nd F8 it goes here
special = Array(Split(Replace(Replace(special1, " ", ""), ",", ", "), ", "), _
    Split(Replace(Replace(special2, " ", ""), ",", ", "), ", "), _
    Split(Replace(Replace(special3, " ", ""), ",", ", "), ", "), _
    Split(Replace(Replace(special4, " ", ""), ",", ", "), ", "), _
    Split(Replace(Replace(special5, " ", ""), ",", ", "), ", "), _
    Split(Replace(Replace(special6, " ", ""), ",", ", "), ", "))
Then goes next next then
goes
Exit For
then
end sub
and finishes sending the email
0
 
Chris BottomleySoftware Quality Lead EngineerCommented:
CAn you supply your full code for tome ... by all means replace each character in the specific addresses with x's per character but otherwise keep it exactly as is, because I don't understand why the population of the array is failing.

Chris
0
 
bsharathAuthor Commented:
Below is the code Chris
Sub toMe(mai As MailItem)
'Dim mai As mailitem
Const Your_email_Addy As String = "smith, fred" ' DISPLAYED NAME!
Dim olkRecip As Object
Dim olkTORecip As Object
Dim special As Variant
Dim index1 As Integer
Dim index2 As Integer
Dim sendto As String
Dim addr As Variant
Const special1 As String = "Sharath uiy, Sharath.uiy@plc.com"
Const special2 As String = ""
Const special3 As String = ""
Const special4 As String = ""
Const special5 As String = ""
Const special6 As String = ""
 
    special = Array(Split(Replace(Replace(special1, " ", ""), ",", ", "), ", "), _
    Split(Replace(Replace(special2, " ", ""), ",", ", "), ", "), _
    Split(Replace(Replace(special3, " ", ""), ",", ", "), ", "), _
    Split(Replace(Replace(special4, " ", ""), ",", ", "), ", "), _
    Split(Replace(Replace(special5, " ", ""), ",", ", "), ", "), _
    Split(Replace(Replace(special6, " ", ""), ",", ", "), ", "))
    
    For index1 = 0 To 5
        sendto = ""
        If UBound(special(index1)) < 2 Then Exit For
        For index2 = 1 To 6
            If UBound(special(index1)) >= index2 Then
                If sendto <> "" Then sendto = sendto & ", "
                If special(index1)(index2) <> "" Then sendto = sendto & special(index1)(index2)
            End If
        Next
        For Each olkTORecip In mai.Recipients
            Debug.Print LCase(olkTORecip.Name) & " = " & LCase(special(index1)(0)) & "? .... " & CStr(LCase(olkTORecip.Name) = LCase(special(index1)(0)))
            If olkTORecip.Type = olTo Then
                If LCase(olkTORecip.Name) = LCase(special(index1)(0)) Then
                    If MsgBox("Append the common CC names" & vbCrLf & vbCrLf & sendto & "?", vbYesNo, "Append common recipients") = vbYes Then
                        For Each addr In Split(sendto, ", ")
                            Set olkRecip = mai.Recipients.Add(addr)
                            olkRecip.Type = olCC
                        Next
                    End If
                    mai.Recipients.ResolveAll
                End If
            End If
        Next
    Next
 
End Sub

Open in new window

0
 
bsharathAuthor Commented:
Below is the code Chris
Sub toMe(mai As MailItem)
'Dim mai As mailitem
Const Your_email_Addy As String = "smith, fred" ' DISPLAYED NAME!
Dim olkRecip As Object
Dim olkTORecip As Object
Dim special As Variant
Dim index1 As Integer
Dim index2 As Integer
Dim sendto As String
Dim addr As Variant
Const special1 As String = "Sharath uiy, Sharath.uiy@plc.com"
Const special2 As String = ""
Const special3 As String = ""
Const special4 As String = ""
Const special5 As String = ""
Const special6 As String = ""
 
    special = Array(Split(Replace(Replace(special1, " ", ""), ",", ", "), ", "), _
    Split(Replace(Replace(special2, " ", ""), ",", ", "), ", "), _
    Split(Replace(Replace(special3, " ", ""), ",", ", "), ", "), _
    Split(Replace(Replace(special4, " ", ""), ",", ", "), ", "), _
    Split(Replace(Replace(special5, " ", ""), ",", ", "), ", "), _
    Split(Replace(Replace(special6, " ", ""), ",", ", "), ", "))
    
    For index1 = 0 To 5
        sendto = ""
        If UBound(special(index1)) < 2 Then Exit For
        For index2 = 1 To 6
            If UBound(special(index1)) >= index2 Then
                If sendto <> "" Then sendto = sendto & ", "
                If special(index1)(index2) <> "" Then sendto = sendto & special(index1)(index2)
            End If
        Next
        For Each olkTORecip In mai.Recipients
            Debug.Print LCase(olkTORecip.Name) & " = " & LCase(special(index1)(0)) & "? .... " & CStr(LCase(olkTORecip.Name) = LCase(special(index1)(0)))
            If olkTORecip.Type = olTo Then
                If LCase(olkTORecip.Name) = LCase(special(index1)(0)) Then
                    If MsgBox("Append the common CC names" & vbCrLf & vbCrLf & sendto & "?", vbYesNo, "Append common recipients") = vbYes Then
                        For Each addr In Split(sendto, ", ")
                            Set olkRecip = mai.Recipients.Add(addr)
                            olkRecip.Type = olCC
                        Next
                    End If
                    mai.Recipients.ResolveAll
                End If
            End If
        Next
    Next
 
End Sub

Open in new window

0
 
Chris BottomleySoftware Quality Lead EngineerCommented:
Okay i've re-done the change to 'format the comma space ... to account for the space in your strings and modified the loop control, basically I made a change in the previous post that I did add to my copy so it has been lost in my earlier posts but I now see what happened ... I am 95% sure there will a difference.

See how it goes now.

Chris
Sub toMe(mai As mailitem)
'Dim mai As mailitem
Const Your_email_Addy As String = "smith, fred" ' DISPLAYED NAME!
Dim olkRecip As Object
Dim olkTORecip As Object
Dim special As Variant
Dim index1 As Integer
Dim index2 As Integer
Dim sendto As String
Dim addr As Variant
'Const special1 As String = "dadt@rose-isle.net,fred1@pc-development.com,   fred2@pc-development.com"
Const special1 As String = "Sharath uiy, Sharath.uiy@plc.com"
Const special2 As String = ""
Const special3 As String = ""
Const special4 As String = ""
Const special5 As String = ""
Const special6 As String = ""
 
    special = Array(Split(Replace(Replace(special1, ",", ", "), "  ", " "), ", "), _
    Split(Replace(Replace(special2, ",", ", "), "  ", " "), ", "), _
    Split(Replace(Replace(special3, ",", ", "), "  ", " "), ", "), _
    Split(Replace(Replace(special4, ",", ", "), "  ", " "), ", "), _
    Split(Replace(Replace(special5, ",", ", "), "  ", " "), ", "), _
    Split(Replace(Replace(special6, ",", ", "), "  ", " "), ", "))
    
    For index1 = 0 To 5
        sendto = ""
        If UBound(special(index1)) < 1 Then Exit For
        For index2 = 1 To 6
            If UBound(special(index1)) >= index2 Then
                If sendto <> "" Then sendto = sendto & ", "
                If special(index1)(index2) <> "" Then sendto = sendto & special(index1)(index2)
            End If
        Next
        For Each olkTORecip In mai.Recipients
            Debug.Print LCase(olkTORecip.Name) & " = " & LCase(special(index1)(0)) & "? .... " & CStr(LCase(olkTORecip.Name) = LCase(special(index1)(0)))
            If olkTORecip.Type = olTo Then
                If LCase(olkTORecip.Name) = LCase(special(index1)(0)) Then
                    If MsgBox("Append the common CC names" & vbCrLf & vbCrLf & sendto & "?", vbYesNo, "Append common recipients") = vbYes Then
                        For Each addr In Split(sendto, ", ")
                            Set olkRecip = mai.Recipients.Add(addr)
                            olkRecip.Type = olCC
                        Next
                    End If
                    mai.Recipients.ResolveAll
                End If
            End If
        Next
    Next
 
End Sub

Open in new window

0
 
Chris BottomleySoftware Quality Lead EngineerCommented:
The first one I may look at but in all honesty the second one you have asked before but every time I look at it I am terrified by it's potential complexity ... so sorry whilst your questions are often good for developing latent skills ... if they look mega then noting the issues that sometimes occur (i.e. you there, me here and no direct connection) it's just not worth starting because I hate not to finish what I start.

Chris
0
 
bsharathAuthor Commented:
Ok Chris i understand....
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.