Hello,
I have a VBA program that determines if the Outlook message I am currently
drafting has any external email addresses in any of the Recipient lists (To: ,
CC: or BCC). If any are found it prompts the user with a list of the external
address(es) and gives him/her the option to delete or ignore. This program
loops through the Recipients twice. First to determine whether there are any
external addresses and then, if the user decides to delete them, it loops
through again to do the deletions. Code pasted below.

For some reason when it loops through the second time it is not seeing all of
the recipients. For example there might be 7 recipients but it only tests 5.
Can anyone tell me what I'm doing wrong here? Thanks.
Best Regards,
Dean

BTW, I originally wrote this program so it would loop through only once, save
the index numbers ( myRecipients(index) ) of the external addresses in an
array and then delete according to the index. However I found that when the
program did the deletions the index numbers were apparently randomly matched
with different recipient addresses, so it was deleting the wrong addresses.


Option Explicit

Public Sub checkExternalRecipients()
On Error GoTo Err_checkExternalRecipients

'************************************************* ********************
'Name:
' checkExternalRecipients
'Type:
' Public Sub, Outlook VBA
'Author:
' Dean Faith
'History:
' Last updated 2006-02-26 17:30
'Purpose:
' Determine if there are any external email addresses in the
To: CC: or BCC: Recipient
' lists of the currently open draft message. If so, prompt
the user with the list of addresses and give them
' the option to delete those addresses or continue. If no
external addresses prompt the user
' with an okOnly prompt. This sub does not distinguish
between To:, CC: and BCC recipients.
'Args:
' None
'Returns:
' Nothing
'************************************************* ********************

'vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv vvvvv
'Dimension all variables
Dim myOlApp As New Outlook.Application
Dim myNameSpace As Outlook.NameSpace
Dim myInbox As Outlook.MAPIFolder
Dim myItems As Outlook.Items
Dim myItem As Object
Dim myRecipients As Recipients
Dim objRecipient As Recipient
Dim strRecipientAddrTemp As String
Dim strExtrnAddr(1 To 500) As String
Dim intNumExtrnlAddr As Integer
Dim intLoopCtr1 As Integer
Dim strUserPrompt As String
'^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ ^^^^^


'vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv vvvvv
'instantiate object and control variables
Set myNameSpace = myOlApp.GetNamespace("MAPI")
Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox)
Set myItems = myInbox.Items
Set myItem = Application.ActiveInspector.CurrentItem
Set myRecipients = myItem.Recipients
'^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ ^^^^^


'vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv vvvvv
'resolve recipients so that any newly typed/unresolved entries can be
recognized by this Sub
myRecipients.ResolveAll
'^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ ^^^^^


'vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv vvvvv
'initialize the flag low, loop through all recipient items and if any have
external email
'addresses set the flag high
intNumExtrnlAddr = 0
For Each objRecipient In myRecipients

If InStr(1, objRecipient.Address, "@") Then

If InStr(1, objRecipient.Address, ") Then
'do nothing
Else
intNumExtrnlAddr = intNumExtrnlAddr + 1
strExtrnAddr(intNumExtrnlAddr) = Left(objRecipient.Address, 25)

End If

Else

End If

Next
'^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ ^^^^^


'vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv vvvvv
'if there are any external addresses in the recipient lists prompt the
user with a list of the addresses and
'the choice to either
'1) delete external addresses and continue editing
'2) delete external addresses and send the message
'3) ignore external addresses and continue editing
'4) ignore external addresses and send the message
If intNumExtrnlAddr Then

'----------------------------------------------------------------
'build a string prompt identifying the external addresses and asking
the user if he/she wants to delete or ignore them
strUserPrompt = "WARNING: The following external recipient addresses
were detected. Click OK to delete or Cancel to ignore. " & _
" [" & strExtrnAddr(1) & "]"
Select Case intNumExtrnlAddr
Case 1
'do nothing
Case Else
For intLoopCtr1 = 2 To intNumExtrnlAddr
strUserPrompt = strUserPrompt & ", [" & strExtrnAddr
(intLoopCtr1) & "]"
Next intLoopCtr1
End Select
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ~~~~~~~~~~~~~~~

'----------------------------------------------------------------
If MsgBox(strUserPrompt, vbOKCancel) = vbOK Then

'loop through all recipient and delete those with external email
addresses
For Each objRecipient In myRecipients

If InStr(1, objRecipient.Address, "@") Then

If InStr(1, objRecipient.Address, ") Then
'do nothing

Else
objRecipient.Delete

End If

End If

Next

End If

Else

'no external addresses found
MsgBox "There are no external addresses in the Recipient Lists",
vbOKOnly

End If
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ~~~~~~~~~~~~~~~
'^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ ^^^^^


'vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv vvvvv
'set object variables = nothing
Set myNameSpace = Nothing
Set myInbox = Nothing
Set myItems = Nothing
Set myItem = Nothing
Set myRecipients = Nothing
Set objRecipient = Nothing
'^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ ^^^^^

Exit_checkExternalRecipients:
Exit Sub
Err_checkExternalRecipients:
MsgBox "sub checkExternalRecipients " & Err.Description
Resume Exit_checkExternalRecipients
End Sub

--
Message posted via OfficeKB.com
http://www.officekb.com/Uwe/Forums.a...g-vba/200602/1

Am Mon, 27 Feb 2006 05:05:20 GMT schrieb saeongjeema via OfficeKB.com:

If you want to delete items from a list/collection then you need to loop
through it backwards. Sample:

For i=Collection.Count To 1 Step -1
' delete Collection(i)
Next


--
Viele Gruesse / Best regards
Michael Bauer - MVP Outlook
-- www.vbOffice.net --


Hello,
I have a VBA program that determines if the Outlook message I am currently
drafting has any external email addresses in any of the Recipient lists
(To: ,
CC: or BCC). If any are found it prompts the user with a list of the
external
address(es) and gives him/her the option to delete or ignore. This program
loops through the Recipients twice. First to determine whether there are
any
external addresses and then, if the user decides to delete them, it loops
through again to do the deletions. Code pasted below.

For some reason when it loops through the second time it is not seeing all
of
the recipients. For example there might be 7 recipients but it only tests
5.
Can anyone tell me what I'm doing wrong here? Thanks.
Best Regards,
Dean

BTW, I originally wrote this program so it would loop through only once,
save
the index numbers ( myRecipients(index) ) of the external addresses in an
array and then delete according to the index. However I found that when
the
program did the deletions the index numbers were apparently randomly
matched
with different recipient addresses, so it was deleting the wrong
addresses.


Option Explicit

Public Sub checkExternalRecipients()
On Error GoTo Err_checkExternalRecipients

'************************************************* ********************
'Name:
' checkExternalRecipients
'Type:
' Public Sub, Outlook VBA
'Author:
' Dean Faith
'History:
' Last updated 2006-02-26 17:30
'Purpose:
' Determine if there are any external email addresses in
the
To: CC: or BCC: Recipient
' lists of the currently open draft message. If so, prompt
the user with the list of addresses and give them
' the option to delete those addresses or continue. If no
external addresses prompt the user
' with an okOnly prompt. This sub does not distinguish
between To:, CC: and BCC recipients.
'Args:
' None
'Returns:
' Nothing
'************************************************* ********************


'vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv vvvvv
'Dimension all variables
Dim myOlApp As New Outlook.Application
Dim myNameSpace As Outlook.NameSpace
Dim myInbox As Outlook.MAPIFolder
Dim myItems As Outlook.Items
Dim myItem As Object
Dim myRecipients As Recipients
Dim objRecipient As Recipient
Dim strRecipientAddrTemp As String
Dim strExtrnAddr(1 To 500) As String
Dim intNumExtrnlAddr As Integer
Dim intLoopCtr1 As Integer
Dim strUserPrompt As String

'^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ ^^^^^



'vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv vvvvv
'instantiate object and control variables
Set myNameSpace = myOlApp.GetNamespace("MAPI")
Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox)
Set myItems = myInbox.Items
Set myItem = Application.ActiveInspector.CurrentItem
Set myRecipients = myItem.Recipients

'^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ ^^^^^



'vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv vvvvv
'resolve recipients so that any newly typed/unresolved entries can be
recognized by this Sub
myRecipients.ResolveAll

'^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ ^^^^^



'vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv vvvvv
'initialize the flag low, loop through all recipient items and if any
have
external email
'addresses set the flag high
intNumExtrnlAddr = 0
For Each objRecipient In myRecipients

If InStr(1, objRecipient.Address, "@") Then

If InStr(1, objRecipient.Address, ") Then
'do nothing
Else
intNumExtrnlAddr = intNumExtrnlAddr + 1
strExtrnAddr(intNumExtrnlAddr) = Left(objRecipient.Address,
25)

End If

Else

End If

Next

'^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ ^^^^^



'vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv vvvvv
'if there are any external addresses in the recipient lists prompt the
user with a list of the addresses and
'the choice to either
'1) delete external addresses and continue editing
'2) delete external addresses and send the message
'3) ignore external addresses and continue editing
'4) ignore external addresses and send the message
If intNumExtrnlAddr Then

'----------------------------------------------------------------
'build a string prompt identifying the external addresses and asking
the user if he/she wants to delete or ignore them
strUserPrompt = "WARNING: The following external recipient addresses
were detected. Click OK to delete or Cancel to ignore. " & _
" [" & strExtrnAddr(1) & "]"
Select Case intNumExtrnlAddr
Case 1
'do nothing
Case Else
For intLoopCtr1 = 2 To intNumExtrnlAddr
strUserPrompt = strUserPrompt & ", [" & strExtrnAddr
(intLoopCtr1) & "]"
Next intLoopCtr1
End Select
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ~~~~~~~~~~~~~~~

'----------------------------------------------------------------
If MsgBox(strUserPrompt, vbOKCancel) = vbOK Then

'loop through all recipient and delete those with external email
addresses
For Each objRecipient In myRecipients

If InStr(1, objRecipient.Address, "@") Then

If InStr(1, objRecipient.Address, ") Then
'do nothing

Else
objRecipient.Delete

End If

End If

Next

End If

Else

'no external addresses found
MsgBox "There are no external addresses in the Recipient Lists",
vbOKOnly

End If
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ~~~~~~~~~~~~~~~

'^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ ^^^^^



'vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv vvvvv
'set object variables = nothing
Set myNameSpace = Nothing
Set myInbox = Nothing
Set myItems = Nothing
Set myItem = Nothing
Set myRecipients = Nothing
Set objRecipient = Nothing

'^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ ^^^^^

Exit_checkExternalRecipients:
Exit Sub
Err_checkExternalRecipients:
MsgBox "sub checkExternalRecipients " & Err.Description
Resume Exit_checkExternalRecipients
End Sub