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

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.

Seems like MVP was not really awake, as this is a common error! See [For Each loop: Some items get skipped when looping through Outlook mailbox to delete items](https://stackoverflow.com/questions/10725068/for-each-loop-some-items-get-skipped-when-looping-through-outlook-mailbox-to-de)! — ComputerVersteher, Mar 07 '20 at 09:46
Thanks for responding. I agree that I need to look backwards and the MVP pointed that out immediately. However, that would not have prevented the code from moving the first item. fortunately I have it working now. — bob alston, Mar 08 '20 at 20:01

score 1 · Answer 1 · answered Mar 09 '20 at 23:41

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

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

1 Answers1