I have a VBA module in Outlook that Looks for a condition to match the Exact Subject and Exact Email address in one Mailbox and then send a reply back (Template) to the recipient of that email. The script was working fine lately getting Error 440 for array out of bounds. When I debug it highlights the line :
Set pa = recips(1).PropertyAccessor"
The code is below.
Option Explicit
Private objNS As Outlook.NameSpace
Private WithEvents objNewMailItems As Outlook.Items
'Update the AWS and Azure auto reply template path
Private Const AWS_AUTO_REPLY = "C:\Users\Documents\AWS_New_Account.oft"
Private Const AZURE_AUTO_REPLY = "C:\Users\Documents\Azure_New_Account.oft"
Private Sub Application_Startup()
Dim objMyInbox As Outlook.MAPIFolder
Dim oAccount As Account
Dim Store As Outlook.Store
'Set objNS = Application.GetNamespace("MAPI")
'For Each oAccount In Session.Accounts
' Set Store = oAccount.DeliveryStore
' Set objMyInbox = Store.GetDefaultFolder(olFolderInbox)
' Set objNewMailItems = objMyInbox.Items
' Set objMyInbox = Nothing
' MsgBox "Application_Startup"
'Next
Set objNS = Application.GetNamespace("MAPI")
Set objMyInbox = objNS.Folders("[email protected]").Folders("Inbox")
Set objNewMailItems = objMyInbox.Items
Set objMyInbox = Nothing
MsgBox "Script Starting"
End Sub
Private Sub objNewMailItems_ItemAdd(ByVal Item As Object)
Dim subjectString As String
Dim senderEmailString As String
Dim recipientEmailString As String
Dim oRespond As Outlook.MailItem
Dim recips As Outlook.Recipients
Dim recip As Outlook.Recipient
Dim pa As Outlook.PropertyAccessor
Const PR_SMTP_ADDRESS As String = "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
Set recips = Item.Recipients
'MsgBox "objNewMailItems_ItemAdd function call"
'Ensure we are only working with e-mail itemshe
If Item.Class <> olMail Then Exit Sub
subjectString = "" Item.Subject
senderEmailString = "" Item.SenderEmailAddress
'GetSMTPAddressForRecipients (Item)
recipientEmailString = ""
Set recips = Item.Recipients
'For Each recip In recips
Set pa = recips(1).PropertyAccessor
recipientEmailString = pa.GetProperty(PR_SMTP_ADDRESS) & ";" & recipientEmailString
'Next
If (InStr(recipientEmailString, "naws") > 0) Or (InStr(recipientEmailString, "xaws") > 0) Or (InStr(recipientEmailString, "saws") > 0) Or (InStr(recipientEmailString, "vcaws") > 0) Or (InStr(recipientEmailString, "daws") > 0) Or (InStr(recipientEmailString, "vaws") > 0) Or (InStr(recipientEmailString, "rovisioningteam") > 0) Then
'MsgBox "D ACCOUNT - DO NOT SEND"
GoTo ENDOFCODE
End If
If InStr(subjectString, "Welcome to your Azure free account") > 0 Then
If InStr(senderEmailString, "[email protected]") > 0 Then
' This sends a response back using a template
' Enter the actual path for
Set oRespond = Application.CreateItemFromTemplate(AZURE_AUTO_REPLY)
With oRespond
'.Recipients.Add Item.To
.Recipients.Add pa.GetProperty(PR_SMTP_ADDRESS)
.Recipients.Add("[email protected]").Type = (olCC)
' includes the original message as an attachment
.Attachments.Add Item
' use this for testing, change to .send once you have it working as desired
'.Display
'.Send
End With
End If
End If
If InStr(subjectString, "[EXT] Welcome to Amazon Web Services") > 0 Then
If InStr(senderEmailString, "[email protected]") > 0 Then
' This sends a response back using a template
'MsgBox "AWS CONDITION"
Set oRespond = Application.CreateItemFromTemplate(AWS_AUTO_REPLY)
With oRespond
'.Recipients.Add Item.To
.Recipients.Add pa.GetProperty(PR_SMTP_ADDRESS)
.Recipients.Add("[email protected]").Type = (olCC)
' includes the original message as an attachment
.Attachments.Add Item
'MsgBox "AWS CONDITION 2"
' use this for testing, change to .send once you have it working as desired
.Display
.Send
End With
End If
End If
ENDOFCODE:
Set oRespond = Nothing
End Sub
Sub GetSMTPAddressForRecipients(mail As Outlook.MailItem)
Dim recips As Outlook.Recipients
Dim recip As Outlook.Recipient
Dim pa As Outlook.PropertyAccessor
Const PR_SMTP_ADDRESS As String = _
"http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
Set recips = mail.Recipients
For Each recip In recips
Set pa = recip.PropertyAccessor
Debug.Print recip.Name & " SMTP=" _
& pa.GetProperty(PR_SMTP_ADDRESS)
Next
End Sub
Function ResolveDisplayNameToSMTP(sFromName) As String
Dim OLApp As Object 'Outlook.Application
Dim oRecip As Object 'Outlook.Recipient
Dim oEU As Object 'Outlook.ExchangeUser
Dim oEDL As Object 'Outlook.ExchangeDistributionList
Set OLApp = CreateObject("Outlook.Application")
Set oRecip = OLApp.Session.CreateRecipient(sFromName)
oRecip.Resolve
If oRecip.Resolved Then
Select Case oRecip.AddressEntry.AddressEntryUserType
Case 0, 5 'olExchangeUserAddressEntry & olExchangeRemoteUserAddressEntry
Set oEU = oRecip.AddressEntry.GetExchangeUser
If Not (oEU Is Nothing) Then
ResolveDisplayNameToSMTP = oEU.PrimarySmtpAddress
End If
Case 10, 30 'olOutlookContactAddressEntry & 'olSmtpAddressEntry
ResolveDisplayNameToSMTP = oRecip.AddressEntry.Address
End Select
End If
End Function
enter code here
Sub Project1()
End Sub
CodePudding user response：
The ItemAdd event can be fired for items that are moved to the folder manually (or created from the ground and saved there). So, there is a chance the Recipients collection will be empty. In that case I'd recommend checking the Recipients.Count property first which returns a long indicating the count of objects in the specified collection.
Also you could use a low-level property which can help with distinguishing between read-only items - the PR_MESSAGE_FLAGS property contains a bitmask of flags that indicate the origin and current state of a message.
Finally, I'd suggest using the GetDefaultFolder method of the Namespace or Store class to retrieve the required folder instead of cryptic names, for example:
objNS.Folders("[email protected]").Folders("Inbox")
If it is the default store you could use the NameSpace.GetDefaultFolder method which returns a Folder object that represents the default folder of the requested type for the current profile; for example, obtains the default Inbox folder for the user who is currently logged on. The Store.GetDefaultFolder method is similar to the GetDefaultFolder method of the NameSpace object. The difference is that this method gets the default folder on the delivery store that is associated with the account, whereas NameSpace.GetDefaultFolder returns the default folder on the default store for the current profile.
CodePudding user response：
You run into a message with no recipients, hence the line accessing the very first recipient fails.
recipientEmailString = ""
For Each recip In recips
Set pa = recip.PropertyAccessor
recipientEmailString = pa.GetProperty(PR_SMTP_ADDRESS) & ";" & recipientEmailString
Next