Move Mails from Inbox to Archive

[rolling_zep]

Hi All,

This is a requirement of an existing code. The below code works and saves the attachment and also marks the read mails as Processed.

But I need to move these Processed mails from the Inbox to the folder, Archive_Proc. I am trying to Set the folder, objDestfolder as the destination folder for these processed mails to be moved. But I am getting object not found error (bolded line).
How to fix the code?




Dim olApp As Object
Dim MYFOLDER As Object
Dim OlItems As Object
Dim olMail As Object
Dim x As Integer
Dim subject As String
Dim strFile As String
Dim strFolderpath As String
Dim objDestfolder As Object
Dim mychar As Object
Dim sreplace As String



Set olApp = GetObject(, "Outlook.Application")
If Err.Number = 429 Then
Set olApp = CreateObject("Outlook.Application")
End If


strFolderpath = "C:\Users\Testing"
'On Error Resume Next


' Set the Attachment folder.
strFolderpath = strFolderpath & "\Attachments\"


Set MYFOLDER = olApp.GetNamespace("MAPI").Folders("WeeklyProceedings Mailbox").Folders("Inbox")

Set OlItems = MYFOLDER.Items


For Each olMail In OlItems
If olMail.subject Like "*Proceeding ID*" Then
strFile = olMail & ".XML"
strFile = strFolderpath & strFile
If olMail.Attachments.Count > 0 Then
For x = 1 To olMail.Attachments.Count
olMail.Attachments.Item(x).SaveAsFile strFile
Next x

subject = olMail.subject
sreplace = "_"
subject = Replace(subject, " ", sreplace)
olMail.Body = olMail.Body & vbCrLf & "The file was processed " & Now()
olMail.subject = "Processed - " & subject
'olMail.Move objDestfolder
olMail.Save


End If
End If


Next


Set objDestfolder = olApp.GetNamespace("MAPI").Folders("WeeklyProceedings Mailbox").Folders("Archive_Proc")
olMail.Move objDestfolder


Set MYFOLDER = Nothing
Set OlMail = Nothing
Set OlItems = Nothing
Set olApp = Nothing
Srt objDestfolder = Nothing

[Aussiebear]

After a quick search on the net, it was suggested that this could work. I've not tried it so no guarantees:


Sub MoveDraftMail()
Dim objOutlook As Outlook.Application
Dim objNamespace As Outlook.NameSpace
Dim objSourceFolder As Outlook.MAPIFolder
Dim objDestFolder As Outlook.MAPIFolder
Dim objItem As Variant
Dim Archive_Folder As Outlook.MAPIFolder
Set objOutlook = New Outlook.Application
Set objNamespace = objOutlook.GetNamespace("MAPI")
Set objSourceFolder = objNamespace.Folders(10).Folders("Name of Folder")
Set Archive_Folder = objNamespace.Folders("Online Archive - My@email").Folders("Personal_Folders").Folders("2021").Folders("InBox")
For Each objItem In objSourceFolder.Items
If TypeName(objItem) = "MailItem" Then
objItem.Move Archive_Folder
End If
Next objItem
Set objDestFolder = Nothing
End Sub

[rolling_zep]

I was able to resolve this issue. Thank you!

[Aussiebear]

Any chance of posting your solution then?

[meghankn]

Oh, yes Aussiebear, your code, it worked. I tried and it moved my email from the "Name of Folder" within the 10th account's mailbox to the "2021\Inbox" folder within an online archive associated with the my email address.

[Aussiebear]

Welcome to VBAX meghankn. Thank you for testing the code.

[meghankn]

Thank you for your welcome.

[namdosan1409]

Use the app object to extract all attachments for a specific sender. Filter the messages with attachments and add all the attachment ids and their corresponding message ids to a list/dict .