Access 365 vba problem with moving specific outlook 365email message to subfolder - vba

Question

Having problems moving Outlook specific mail item to subfolder. I have spent time with an Outlook MVP on Access Vba Code To Move Outlook Mail Item To Different Folder Fails - Sometimes to figure this out.
Just determined that Windows 10 Access and Outlook 2019 show the same behavior. so it must be in the code??
Maybe need an experienced Access person to take a look.
I have verified that:
Dim Mailobject As Outlook.MailItem
Dim myDestFolder As Outlook.MAPIFolder
immediately before the MOVE code, I have verified that Mailobject is still defined and is what I want by printing mailobject.subject and mailobject.sender.
I have verified myDestFolder by printing mydestfolder.name and mydestfolder.folderpath
Note that the code does work occasionally but certainly not very often.
I have listed below my code without the processing I do on each message and hiding an email address:
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
Note that I have tried this in windows 10 with Access 2019 and Outlook 2019 with the same results/same problem.

Answer 1

OK this is code that works. It obviously has a backwards processing of messages in the inbox to avoid problems with inability to MOVE more than one matching message. However my original code code not MOVE ANY matching messages.
The code I used as a base for this solution is from a web site listed at the beginning of my code as a comment. I am thankful for that code.
Public Sub ReadInbox()
'' http://www.vbaexpress.com/forum/showthread.php?58433-VBA-Outlook-Move-mail-shared-Folder-to-shared-subfolder
Dim a As Boolean
'''******Open Outlook if not already open
On Error Resume Next
Set myOlApp = GetObject(, "outlook.Application")
If Err.Number <> 0 Then
Set myOlApp = CreateObject("Outlook.Application")
End If
On Error GoTo error_Handling
'''http://www.blueclaw-db.com/read_email_access_outlook.htm
'''On Error GoTo error_Handling
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 OlApp As Outlook.Application
Dim Inbox As Outlook.MAPIFolder
Dim InboxItems As Outlook.items
Dim Mailobject As Object
Dim db As DAO.Database
Dim dealer As Integer
Dim MessageBody As String
Dim selstr As String
Dim myDestFolder As Outlook.folder
Dim myInbox As Outlook.folder
Dim alreadyindb As Boolean
Dim n As Integer
'****
Set mynamespace = myOlApp.getnamespace("MAPI")
Dim NS As namespace
Dim Destinationfolder As folder
Dim myitems As Outlook.items
Dim myInbox2 As folder
Set NS = myOlApp.getnamespace("MAPI")
Set myInbox = NS.Folders("volunteerform#?????.org").Folders("Inbox")
Set myitems = myInbox.items
Set myInbox2 = NS.Folders("volunteerform#?????.org").Folders("inbox")
If myInbox2 Is Nothing Then
Exit Sub ' avoid error if no account is chosen
End If
Set myitems = myInbox2.items
'
''''For Each Mailobject In myitems
For n = myitems.Count To 1 Step -1
'''MsgBox ("process mailobject")
If myitems(n).Subject <> "ANV Volunteer Form Submission for Import" Then GoTo NextMessage
'************* all my processing here ********************
NextMessage:
' Next email message
Next n
'''Set OlApp = Nothing
Set myInbox2 = Nothing
Set InboxItems = Nothing
Set Mailobject = Nothing
Exit Sub
error_Handling:
Dim errornumber As String
Dim errordescr As String
errornumber = Err.Number
errordescr = Err.Description
a = WriteHistory("Process Form Retrieve_ProcessEmails", "Error = " & errornumber & " Mysection = " & MySection & " errordescription = " & errordescr & " MySection=" & MySection)
Exit Sub
End Sub