【发布时间】：2023-03-18 11:13:01
【问题描述】：
将 Outlook 特定邮件项移动到子文件夹时遇到问题。我曾在Access Vba Code To Move Outlook Mail Item To Different Folder Fails - Sometimes 上使用 Outlook MVP 来解决这个问题。
刚刚确定 Windows 10 Access 和 Outlook 2019 显示相同的行为。所以它必须在代码中？？
可能需要有经验的 Access 人员来看看。
我已验证：
将邮件对象变暗为 Outlook.MailItem 将 myDestFolder 调暗为 Outlook.MAPIFolder
在 MOVE 代码之前，我通过打印 mailobject.subject 和 mailobject.sender 验证了 Mailobject 仍然是定义的并且是我想要的。
我已通过打印 mydestfolder.name 和 mydestfolder.folderpath 验证了 myDestFolder
请注意，代码偶尔会运行，但肯定不会经常运行。
我在我的代码下方列出了我对每条消息进行的处理并隐藏了一个电子邮件地址：
Public Sub ReadInbox()
Dim a As Boolean
'''http://www.blueclaw-db.com/read_email_access_outlook.htm
Dim TempRst As DAO.Recordset
Dim TempRst2 As DAO.Recordset
Dim TempRst3 As DAO.Recordset
Dim TempRst4 As DAO.Recordset
Dim rst As DAO.Recordset
Dim mynamespace As Outlook.NameSpace
Dim myOlApp As Outlook.Application
On Error Resume Next
Set myOlApp = GetObject(, "outlook.Application")
If Err.Number <> 0 Then
Set myOlApp = CreateObject("Outlook.Application")
End If
On Error GoTo 0
Set mynamespace = myOlApp.GetNamespace("MAPI")
Dim Inbox As Outlook.MAPIFolder
Dim InboxItems As Outlook.Items
Dim Mailobject As Outlook.MailItem
Dim db As DAO.Database
Dim selstr As String
Dim myDestFolder As Outlook.MAPIFolder
Dim myInbox As Outlook.folder
Dim myInbox2 As Outlook.MAPIFolder
Dim myitems As Outlook.Items
Dim strFilter As String
' let the user choose which account to use
Set myaccounts = myOlApp.GetNamespace("MAPI").Stores
For i = 1 To myaccounts.Count
If myaccounts.Item(i).DisplayName = "volunteerform@?????.org" Then
Set Items = GetFolderPath("volunteerform@?????.org\inbox").Items
Set myInbox2 = mynamespace.Folders("volunteerform@?????.org")
Exit For
End If
Next
If myInbox2 Is Nothing Then
'If Items Is Nothing Then
MsgBox ("mailbox not found")
Exit Sub ' avoid error if no account is chosen
End If
'
'''''Set InboxItems = myInbox2.Items
Set InboxItems = Items
'
For Each Mailobject In InboxItems
If Mailobject.Subject <> "test" Then GoTo NextMessage
MsgBox ("found one message")
'**** do my processing here *****
On Error GoTo 0
'Set myDestFolder = GetFolderPath("volunteerform@????.org\inbox\Volunteeremailsprocessed")
Set myDestFolder = myInbox2.Folders("Inbox")
Set myDestFolder = myDestFolder.Folders("Volunteeremailsprocessed")
'Set myDestFolder = myInbox2.Folders("Volunteeremailsprocessed")
Stop
Mailobject.Move myDestFolder
NextMessage:
' Next email message
Next Mailobject
'''Set OlApp = Nothing
Set myInbox2 = Nothing
Set InboxItems = Nothing
Set Mailobject = Nothing
Exit Sub
error_Handling:
Stop
Dim errornumber As String
Dim errordescr As String
errornumber = Err.Number
errordescr = Err.Description
MsgBox (errornumber + " " + errordesc)
Exit Sub
End Sub
请注意，我已在 Windows 10 中使用 Access 2019 和 Outlook 2019 进行了尝试，但结果相同/问题相同。
【问题讨论】：
-
似乎 MVP 并没有真正醒来，因为这是一个常见错误！见For Each loop: Some items get skipped when looping through Outlook mailbox to delete items!
-
感谢您的回复。我同意我需要回头看，MVP 立即指出了这一点。但是，这不会阻止代码移动第一项。幸运的是，我现在可以使用它了。