Move and mark as read all messages from subfolder

[stogdengys]

Hello. I have VBA code that saves my attachments from "AISnauji" subfolder to my computer. Now i need to move all messages from subfolder "AISnauji" to subfolder "AIS" and mark them as read. Can anybody help me? Thanks in advance.

Sub GetAttachments()

Dim ns As NameSpace
Dim SubFolder As MAPIFolder
Dim Item As Object
Dim Atmt As Attachment
Dim FileName As String
Dim i As Integer

Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
Set SubFolder = Inbox.Folders("AISnauji")
i = 0

If SubFolder.Items.count = 0 Then
MsgBox "There are no messages in the Inbox.", vbInformation, _
"Nothing Found"
Exit Sub
End If

If SubFolder.Items.count > 0 Then
For Each Item In SubFolder.Items
For Each Atmt In Item.Attachments
FileName = "G:\korteles\ISSUING\AIS\2015" & _
Format(Item.SentOn, "mmdd_hhnn_") & Atmt.FileName
Atmt.SaveAsFile FileName
i = i + 1
Next Atmt
Next Item
End If

If i > 0 Then
MsgBox "I found " & i & " attached files." _
& vbCrLf & "I have saved them into the G:\korteles\ISSUING\AIS folder." _
& vbCrLf & vbCrLf & "Have a nice day, Dalius!", vbInformation, "Finished!"
Else
MsgBox "I didn't find any attached files in your mail.", vbInformation, _
"Finished!"
End If

GetAttachments_exit:
Set Atmt = Nothing
Set Item = Nothing
Set ns = Nothing
Exit Sub

GetAttachments_err:
MsgBox "An unexpected error has occurred." _
& vbCrLf & "Please note and report the following information." _
& vbCrLf & "Macro Name: GetAttachments" _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Resume GetAttachments_exit
Exit Sub
End Sub

[gmayor]

Not tested and assuming AIS is a sub folder of Inbox then



Option Explicit

Sub GetAttachments()

Dim ns As NameSpace
Dim oInbox As Folder
Dim SubFolder As MAPIFolder
Dim Item As MailItem
Dim Atmt As Attachment
Dim FileName As String
Dim i As Integer
Dim lngItem As Long

Set ns = GetNamespace("MAPI")
Set oInbox = ns.GetDefaultFolder(olFolderInbox)
Set SubFolder = oInbox.folders("AISnauji")
i = 0

If SubFolder.Items.Count = 0 Then
MsgBox "There are no messages in the Inbox.", vbInformation, _
"Nothing Found"
Exit Sub
End If

If SubFolder.Items.Count > 0 Then
For lngItem = SubFolder.Items.Count To 1 Step -1 'process in reverse
Set Item = SubFolder.Items(lngItem)
For Each Atmt In Item.Attachments
FileName = "G:\korteles\ISSUING\AIS\2015" & _
Format(Item.SentOn, "mmdd_hhnn_") & Atmt.FileName
Atmt.SaveAsFile FileName
i = i + 1
Next Atmt
Item.UnRead = False
Item.Move oInbox.folders("AIS")
Next lngItem
End If

If i > 0 Then
MsgBox "I found " & i & " attached files." _
& vbCrLf & "I have saved them into the G:\korteles\ISSUING\AIS folder." _
& vbCrLf & vbCrLf & "Have a nice day, Dalius!", vbInformation, "Finished!"
Else
MsgBox "I didn't find any attached files in your mail.", vbInformation, _
"Finished!"
End If

GetAttachments_exit:
Set Atmt = Nothing
Set Item = Nothing
Set ns = Nothing
Set oInbox = Nothing
Exit Sub

GetAttachments_err:
MsgBox "An unexpected error has occurred." _
& vbCrLf & "Please note and report the following information." _
& vbCrLf & "Macro Name: GetAttachments" _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Resume GetAttachments_exit
Exit Sub
End Sub

[stogdengys]

Simple and easy! Thank you for really quick help!