Sub movemailtofolder()
Dim ol As Object 'Outlook.Application
Dim ns As Object 'Outlook.Namespace
Dim inboxFol As Object 'Outlook.Folder
Dim subFol As Object 'Outlook.Folder
Dim itm As Object
Dim mi As Object 'Outlook.MailItem
Dim att As Object 'Outlook.Attachment
Dim fso As Object 'Scripting.FileSystemObject
Dim dirName As String
Dim xDate As Date
Dim DateStart As Date
Dim DateEnd As Date
'get date 1 day back
DateStart = Date - 1
'get todays date
DateEnd = Date
Dim datetocheck As String
'Some Set Ups
Set fso = CreateObject(Class:="Scripting.FileSystemObject")
Set ol = CreateObject(Class:="Outlook.Application")
Set ns = ol.GetNamespace("MAPI")
Set inboxFol = ns.Folders("allsourav@gmail.com").Folders("Inbox") 'olFolderInbox
Set subFol = inboxFol.Folders("test")
' dirName = "D:\XYZ"
' If Not fso.FolderExists(dirName) Then
' fso.CreateFolder dirName
' End If
'search by date and time
datetocheck = "[ReceivedTime] >= '" & Format(DateStart, "ddddd h:nn AMPM") & "' And [ReceivedTime] <= '" & Format(DateEnd, "ddddd h:nn AMPM") & "'"
MsgBox (datetocheck)
'Finding the search item from Oulook Inbox
For Each itm In inboxFol.Items.Restrict(datetocheck)
If itm.Class = 43 Then
Set mi = itm
' If mi.Attachments.count > 0 And InStr(mi.SenderEmailAddress, "xxxxxxx@inc.ae") Then
' 'Saving Attachments to a folder
' For Each att In mi.Attachments
' If Right(att.Filename, 4) = "xlsm" Then
' att.SaveAsFile dirName & "\" & Range("Ad2").Text & ".xlsm"
' End If
' Next att
' 'Move mail item to subfolder
' mi.Move subFol
' End If
mi.Move subFol
End If
Next itm
End Sub
Source:https://techcommunity.microsoft.com/t5/excel/vba-moving-a-mail-from-inbox-to-a-specific-folder/m-p/1926973
No comments:
Post a Comment