错误 440 数组索引越界 - Outlook 365 - VBA - 请帮助
Error 440 array index out of bounds - Outook 365 - VBA - Please Hep
我在 Outlook 中有一个 VBA 模块，它查找一个条件来匹配一个邮箱中的确切主题和确切电子邮件地址，然后将回复（模板）发送回该电子邮件的收件人。该脚本最近运行良好，因为数组越界而出现错误 440。当我调试时，它会突出显示该行：
Set pa = recips(1).PropertyAccessor"
代码如下
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("NewCloudAcct@xyz.com").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, "azure-noreply@microsoft.com") > 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("NewCloudAcct@xyz.com").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, "no-reply-aws@amazon.com") > 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("NewCloudAcct@xyz.com").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
您 运行 进入了一封没有收件人的邮件，因此访问第一个收件人的线路失败。
recipientEmailString = ""
For Each recip In recips
Set pa = recip.PropertyAccessor
recipientEmailString = pa.GetProperty(PR_SMTP_ADDRESS) & ";" & recipientEmailString
Next
可以为手动移动到文件夹（或从地面创建并保存在那里）的项目触发 ItemAdd 事件。因此，Recipients 集合有可能为空。在那种情况下，我建议首先检查 Recipients.Count 属性，其中 returns 一个 long 表示指定集合中的对象数。
您还可以使用 low-level 属性 来帮助区分 read-only 项 - PR_MESSAGE_FLAGS 属性 包含标志的位掩码指示消息的来源和当前状态。
最后，我建议使用命名空间或存储 class 的 GetDefaultFolder 方法来检索所需的文件夹而不是神秘的名称，例如：
objNS.Folders("NewCloudAcct@xyz.com").Folders("Inbox")
如果它是默认存储，您可以使用 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 方法类似于 NameSpace 对象的 GetDefaultFolder 方法。不同之处在于此方法获取与帐户关联的交付商店中的默认文件夹，而 NameSpace.GetDefaultFolder returns 当前配置文件的默认商店中的默认文件夹。
我在 Outlook 中有一个 VBA 模块，它查找一个条件来匹配一个邮箱中的确切主题和确切电子邮件地址，然后将回复（模板）发送回该电子邮件的收件人。该脚本最近运行良好，因为数组越界而出现错误 440。当我调试时，它会突出显示该行：
Set pa = recips(1).PropertyAccessor"
代码如下
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("NewCloudAcct@xyz.com").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, "azure-noreply@microsoft.com") > 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("NewCloudAcct@xyz.com").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, "no-reply-aws@amazon.com") > 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("NewCloudAcct@xyz.com").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
您 运行 进入了一封没有收件人的邮件，因此访问第一个收件人的线路失败。
recipientEmailString = ""
For Each recip In recips
Set pa = recip.PropertyAccessor
recipientEmailString = pa.GetProperty(PR_SMTP_ADDRESS) & ";" & recipientEmailString
Next
可以为手动移动到文件夹（或从地面创建并保存在那里）的项目触发 ItemAdd 事件。因此，Recipients 集合有可能为空。在那种情况下，我建议首先检查 Recipients.Count 属性，其中 returns 一个 long 表示指定集合中的对象数。
您还可以使用 low-level 属性 来帮助区分 read-only 项 - PR_MESSAGE_FLAGS 属性 包含标志的位掩码指示消息的来源和当前状态。
最后，我建议使用命名空间或存储 class 的 GetDefaultFolder 方法来检索所需的文件夹而不是神秘的名称，例如：
objNS.Folders("NewCloudAcct@xyz.com").Folders("Inbox")
如果它是默认存储，您可以使用 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 方法类似于 NameSpace 对象的 GetDefaultFolder 方法。不同之处在于此方法获取与帐户关联的交付商店中的默认文件夹，而 NameSpace.GetDefaultFolder returns 当前配置文件的默认商店中的默认文件夹。