S
saeongjeema via OfficeKB.com
Hi, I have a VBA program that scans through all of the recipients in a draft
message to determine if there are any external recipients. Complete code
listed at the bottom. The sub runs very slow. The culprit seems to be
the Distribution List related operations. The specific lines of code that run
very slow are pasted directly below.
intNumDistrListMembers(intLoopCtr_1) = myRecipients.Item(intLoopCtr_1).
AddressEntry.Members.Count
strRecipientAddrTemp = Trim(myRecipients.Item(intLoopCtr_1).AddressEntry.
Members.Item(intLoopCtr_2).Address)
Thanks in advance for any help.
Best Regards,
Dean
Public Sub checkForExternalRecipients()
On Error GoTo Err_checkForExternalRecipients
'*********************************************************************
'Name:
' checkForExternalRecipients
'Type:
' Public Sub, Outlook VBA
'Author:
' Dean Faith
'History:
' Last updated 2006-03-13 21: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 are present it prompts the user
' with an okOnly prompt. This sub does not distinguish
between To:, CC: and BCC recipients.
'Args:
' None
'Returns:
' Nothing
'Notes:
' This program can only deal with a maximum of 500 email
addresses and distribution lists, and a maximum of
' 500 members in any single distr list. These limits are set
by the arrays bytExternalAddrFlag and intNumDistrListMembers
'*********************************************************************
'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 intNumRecipients As Integer
Dim strRecipientAddrTemp As String
Dim strRecipientNameTemp As String
Dim strInternalAddrQualifier As String
Dim bytExternalAddrFlag(1 To 500, 1 To 500) As Byte
Dim bytMasterExternalAddrFlag As Byte
Dim intNumDistrListMembers(1 To 500) As Integer
Dim intLoopCtr_1 As Integer
Dim intLoopCtr_2 As Integer
Dim bytUserPromptDeleteExternalAddrYN As Byte
'vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
'instantiate object 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
'set the internal address qualifer string, If the address is entered as an
external type address (which is detected by the presence of an "@"
'character) then this qualifier string is a common string that would be
found in the external address string of all internal company addresses
strInternalAddrQualifier = "@conexant.com"
'^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
'vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
'set the flag, if the user is prompted to delete or ignore the external
addresses and answers yes (delete) this
'flag will be set high
bytUserPromptDeleteExternalAddrYN = 0
'^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
'vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
'resolve recipients so that any newly typed/unresolved entries can be
recognized by this Sub
myRecipients.ResolveAll
'^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
'vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
'determine how many total recipients in the currently open message compose
form and redim the array variables
intNumRecipients = myRecipients.Count
'^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
'vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
'loop through each recipient item and write the appropriate flag values to
the array variables
'if one or more of the addresses is an internal address set the
bytMasterExternalAddrFlag byte according to the
'following table, Note: a ghost address is a string of blanks, null or
zero length string
' 0 means there are no External or Ghost addresses
' 1 means there are External but no Ghost addresses
' 2 means there are Ghost but no External addresses
' 3 means there are both External and Ghost addresses
bytMasterExternalAddrFlag = 0
For intLoopCtr_1 = 1 To intNumRecipients
'set the variable which holds the number of distr list recipients for
this email addr or distr list, a value of 1 means
'it is an email address and a value of 2 or more means it's a distr
list
If myRecipients.Item(intLoopCtr_1).DisplayType Then
intNumDistrListMembers(intLoopCtr_1) = myRecipients.Item
(intLoopCtr_1).AddressEntry.Members.Count
Else
intNumDistrListMembers(intLoopCtr_1) = 1
End If
For intLoopCtr_2 = 1 To intNumDistrListMembers(intLoopCtr_1)
'hold the recipient address string in a temporary variable for
analysis
Select Case myRecipients.Item(intLoopCtr_1).DisplayType
Case 0
'single email address
strRecipientAddrTemp = Trim(myRecipients.Item(intLoopCtr_1).
Address)
Case Else
'distr list, read address for this member
strRecipientAddrTemp = Trim(myRecipients.Item(intLoopCtr_1).
AddressEntry.Members.Item(intLoopCtr_2).Address)
End Select
If Len(strRecipientAddrTemp) Then
'this is not a ghost address
If InStr(1, strRecipientAddrTemp, "@") Then
If InStr(1, strRecipientAddrTemp, strInternalAddrQualifier)
Then
'this is an internal address (in external format), set the
flag variables as appropriate
bytExternalAddrFlag(intLoopCtr_1, intLoopCtr_2) = 0
Else
'this is an external address, set the flag variables as
appropriate
bytExternalAddrFlag(intLoopCtr_1, intLoopCtr_2) = 1
Select Case bytMasterExternalAddrFlag
Case 0
bytMasterExternalAddrFlag = 1
Case 2
bytMasterExternalAddrFlag = 3
Case Else
'do nothing
End Select
End If
Else
'this is an internal address, set the flag variables as
appropriate
bytExternalAddrFlag(intLoopCtr_1, intLoopCtr_2) = 0
End If
Else
'this is a ghost address, set the flag variables as appropriate
bytExternalAddrFlag(intLoopCtr_1, intLoopCtr_2) = 2
Select Case bytMasterExternalAddrFlag
Case 0
bytMasterExternalAddrFlag = 2
Case 1
bytMasterExternalAddrFlag = 3
Case Else
'do nothing
End Select
End If
Next intLoopCtr_2
Next intLoopCtr_1
'^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
'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 delete the external addresses or ignore the external
addresses and send the message
'delete all ghost addresses
Select Case bytMasterExternalAddrFlag
Case 1, 2, 3
'there are External and/or Ghost addresses
'if there are external addresses prompt the user to determine
whether to delete them or not
Select Case bytMasterExternalAddrFlag
Case 1, 3
If MsgBox("WARNING: External recipient addresses were detected.
Delete (Y/N)", vbYesNo) Then
bytUserPromptDeleteExternalAddrYN = 1
End If
End Select
For intLoopCtr_1 = intNumRecipients To 1 Step -1
For intLoopCtr_2 = intNumDistrListMembers(intLoopCtr_1) To 1 Step
-1
Select Case bytExternalAddrFlag(intLoopCtr_1, intLoopCtr_2)
Case 1
'external address
If bytUserPromptDeleteExternalAddrYN Then
'user wants to delete
Select Case myRecipients.Item(intLoopCtr_1).
DisplayType
Case 0
'single email address
myRecipients.Item(intLoopCtr_1).Delete
Case Else
'distr list, read address for this member
myRecipients.Item(intLoopCtr_1).AddressEntry.
Members.Item(intLoopCtr_2).Delete
End Select
End If
Case 2
'ghost address, so delete regardless of
bytUserPromptDeleteExternalAddrYN value
Select Case myRecipients.Item(intLoopCtr_1).DisplayType
Case 0
'single email address
myRecipients.Item(intLoopCtr_1).Delete
Case Else
'distr list, read address for this member
myRecipients.Item(intLoopCtr_1).AddressEntry.
Members.Item(intLoopCtr_2).Delete
End Select
End Select
Next intLoopCtr_2
Next intLoopCtr_1
Case Else
'no external addresses found
MsgBox "There are no external addresses in the Recipient Lists",
vbOKOnly
End Select
'^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
'vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
'set object variables = nothing
Set myNameSpace = Nothing
Set myInbox = Nothing
Set myItems = Nothing
Set myItem = Nothing
Set myRecipients = Nothing
Set objRecipient = Nothing
'^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Exit_checkForExternalRecipients:
Exit Sub
Err_checkForExternalRecipients:
MsgBox "sub checkForExternalRecipients " & Err.Description
Resume Exit_checkForExternalRecipients
End Sub
message to determine if there are any external recipients. Complete code
listed at the bottom. The sub runs very slow. The culprit seems to be
the Distribution List related operations. The specific lines of code that run
very slow are pasted directly below.
intNumDistrListMembers(intLoopCtr_1) = myRecipients.Item(intLoopCtr_1).
AddressEntry.Members.Count
strRecipientAddrTemp = Trim(myRecipients.Item(intLoopCtr_1).AddressEntry.
Members.Item(intLoopCtr_2).Address)
Thanks in advance for any help.
Best Regards,
Dean
Public Sub checkForExternalRecipients()
On Error GoTo Err_checkForExternalRecipients
'*********************************************************************
'Name:
' checkForExternalRecipients
'Type:
' Public Sub, Outlook VBA
'Author:
' Dean Faith
'History:
' Last updated 2006-03-13 21: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 are present it prompts the user
' with an okOnly prompt. This sub does not distinguish
between To:, CC: and BCC recipients.
'Args:
' None
'Returns:
' Nothing
'Notes:
' This program can only deal with a maximum of 500 email
addresses and distribution lists, and a maximum of
' 500 members in any single distr list. These limits are set
by the arrays bytExternalAddrFlag and intNumDistrListMembers
'*********************************************************************
'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 intNumRecipients As Integer
Dim strRecipientAddrTemp As String
Dim strRecipientNameTemp As String
Dim strInternalAddrQualifier As String
Dim bytExternalAddrFlag(1 To 500, 1 To 500) As Byte
Dim bytMasterExternalAddrFlag As Byte
Dim intNumDistrListMembers(1 To 500) As Integer
Dim intLoopCtr_1 As Integer
Dim intLoopCtr_2 As Integer
Dim bytUserPromptDeleteExternalAddrYN As Byte
'vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
'instantiate object 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
'set the internal address qualifer string, If the address is entered as an
external type address (which is detected by the presence of an "@"
'character) then this qualifier string is a common string that would be
found in the external address string of all internal company addresses
strInternalAddrQualifier = "@conexant.com"
'^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
'vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
'set the flag, if the user is prompted to delete or ignore the external
addresses and answers yes (delete) this
'flag will be set high
bytUserPromptDeleteExternalAddrYN = 0
'^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
'vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
'resolve recipients so that any newly typed/unresolved entries can be
recognized by this Sub
myRecipients.ResolveAll
'^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
'vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
'determine how many total recipients in the currently open message compose
form and redim the array variables
intNumRecipients = myRecipients.Count
'^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
'vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
'loop through each recipient item and write the appropriate flag values to
the array variables
'if one or more of the addresses is an internal address set the
bytMasterExternalAddrFlag byte according to the
'following table, Note: a ghost address is a string of blanks, null or
zero length string
' 0 means there are no External or Ghost addresses
' 1 means there are External but no Ghost addresses
' 2 means there are Ghost but no External addresses
' 3 means there are both External and Ghost addresses
bytMasterExternalAddrFlag = 0
For intLoopCtr_1 = 1 To intNumRecipients
'set the variable which holds the number of distr list recipients for
this email addr or distr list, a value of 1 means
'it is an email address and a value of 2 or more means it's a distr
list
If myRecipients.Item(intLoopCtr_1).DisplayType Then
intNumDistrListMembers(intLoopCtr_1) = myRecipients.Item
(intLoopCtr_1).AddressEntry.Members.Count
Else
intNumDistrListMembers(intLoopCtr_1) = 1
End If
For intLoopCtr_2 = 1 To intNumDistrListMembers(intLoopCtr_1)
'hold the recipient address string in a temporary variable for
analysis
Select Case myRecipients.Item(intLoopCtr_1).DisplayType
Case 0
'single email address
strRecipientAddrTemp = Trim(myRecipients.Item(intLoopCtr_1).
Address)
Case Else
'distr list, read address for this member
strRecipientAddrTemp = Trim(myRecipients.Item(intLoopCtr_1).
AddressEntry.Members.Item(intLoopCtr_2).Address)
End Select
If Len(strRecipientAddrTemp) Then
'this is not a ghost address
If InStr(1, strRecipientAddrTemp, "@") Then
If InStr(1, strRecipientAddrTemp, strInternalAddrQualifier)
Then
'this is an internal address (in external format), set the
flag variables as appropriate
bytExternalAddrFlag(intLoopCtr_1, intLoopCtr_2) = 0
Else
'this is an external address, set the flag variables as
appropriate
bytExternalAddrFlag(intLoopCtr_1, intLoopCtr_2) = 1
Select Case bytMasterExternalAddrFlag
Case 0
bytMasterExternalAddrFlag = 1
Case 2
bytMasterExternalAddrFlag = 3
Case Else
'do nothing
End Select
End If
Else
'this is an internal address, set the flag variables as
appropriate
bytExternalAddrFlag(intLoopCtr_1, intLoopCtr_2) = 0
End If
Else
'this is a ghost address, set the flag variables as appropriate
bytExternalAddrFlag(intLoopCtr_1, intLoopCtr_2) = 2
Select Case bytMasterExternalAddrFlag
Case 0
bytMasterExternalAddrFlag = 2
Case 1
bytMasterExternalAddrFlag = 3
Case Else
'do nothing
End Select
End If
Next intLoopCtr_2
Next intLoopCtr_1
'^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
'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 delete the external addresses or ignore the external
addresses and send the message
'delete all ghost addresses
Select Case bytMasterExternalAddrFlag
Case 1, 2, 3
'there are External and/or Ghost addresses
'if there are external addresses prompt the user to determine
whether to delete them or not
Select Case bytMasterExternalAddrFlag
Case 1, 3
If MsgBox("WARNING: External recipient addresses were detected.
Delete (Y/N)", vbYesNo) Then
bytUserPromptDeleteExternalAddrYN = 1
End If
End Select
For intLoopCtr_1 = intNumRecipients To 1 Step -1
For intLoopCtr_2 = intNumDistrListMembers(intLoopCtr_1) To 1 Step
-1
Select Case bytExternalAddrFlag(intLoopCtr_1, intLoopCtr_2)
Case 1
'external address
If bytUserPromptDeleteExternalAddrYN Then
'user wants to delete
Select Case myRecipients.Item(intLoopCtr_1).
DisplayType
Case 0
'single email address
myRecipients.Item(intLoopCtr_1).Delete
Case Else
'distr list, read address for this member
myRecipients.Item(intLoopCtr_1).AddressEntry.
Members.Item(intLoopCtr_2).Delete
End Select
End If
Case 2
'ghost address, so delete regardless of
bytUserPromptDeleteExternalAddrYN value
Select Case myRecipients.Item(intLoopCtr_1).DisplayType
Case 0
'single email address
myRecipients.Item(intLoopCtr_1).Delete
Case Else
'distr list, read address for this member
myRecipients.Item(intLoopCtr_1).AddressEntry.
Members.Item(intLoopCtr_2).Delete
End Select
End Select
Next intLoopCtr_2
Next intLoopCtr_1
Case Else
'no external addresses found
MsgBox "There are no external addresses in the Recipient Lists",
vbOKOnly
End Select
'^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
'vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
'set object variables = nothing
Set myNameSpace = Nothing
Set myInbox = Nothing
Set myItems = Nothing
Set myItem = Nothing
Set myRecipients = Nothing
Set objRecipient = Nothing
'^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Exit_checkForExternalRecipients:
Exit Sub
Err_checkForExternalRecipients:
MsgBox "sub checkForExternalRecipients " & Err.Description
Resume Exit_checkForExternalRecipients
End Sub