S
saeongjeema via OfficeKB.com
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
'*********************************************************************
'vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
'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
'^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
'vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
'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
'^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
'vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
'resolve recipients so that any newly typed/unresolved entries can be
recognized by this Sub
myRecipients.ResolveAll
'^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
'vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
'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, "@conexant.com") Then
'do nothing
Else
intNumExtrnlAddr = intNumExtrnlAddr + 1
strExtrnAddr(intNumExtrnlAddr) = Left(objRecipient.Address, 25)
End If
Else
End If
Next
'^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
'vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
'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, "@conexant.com") 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
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
'vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
'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
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
'*********************************************************************
'vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
'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
'^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
'vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
'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
'^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
'vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
'resolve recipients so that any newly typed/unresolved entries can be
recognized by this Sub
myRecipients.ResolveAll
'^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
'vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
'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, "@conexant.com") Then
'do nothing
Else
intNumExtrnlAddr = intNumExtrnlAddr + 1
strExtrnAddr(intNumExtrnlAddr) = Left(objRecipient.Address, 25)
End If
Else
End If
Next
'^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
'vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
'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, "@conexant.com") 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
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
'vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
'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