Skip to main content
Support is Online
We're back! We are here to assist you. Please be patient, we will respond to your tickets shortly.
Official support hours
Monday To Friday
From 09:00 To 17:30
  Monday, 05 November 2018
  2 Replies
  5.2K Visits
0
Votes
Undo
My code works.
The code does that all I want.
A code that is too complex. I think it must be shorter.
I have to enter up to 200 folders and in this way I have to do a very long code.
All messages in all incoming mail folders must be checked. All but 2 folders. The folders that do not need to be checked are called: "" and "".
Does anyone help me?
Thank you.

Sub MoveItems7TEST()

Dim myNameSpace As Outlook.NameSpace
Dim myInbox As Outlook.Folder
Dim myInbox2 As Outlook.Folder
Dim myInbox3 As Outlook.Folder

Dim myDestFolder As Outlook.Folder

Dim myItems As Outlook.Items
Dim myItems2 As Outlook.Items
Dim myItems3 As Outlook.Items

Dim myItem As Object

Set myNameSpace = Application.GetNamespace("MAPI")
'Posta in arrivo
Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox)
'Stef
Set myInbox2 = myNameSpace.GetDefaultFolder(olFolderInbox).Folders("Stef")
'Servizio
Set myInbox3 = myNameSpace.GetDefaultFolder(olFolderInbox).Folders("Servizio")

Set myItems = myInbox.Items
Set myItems2 = myInbox2.Items
Set myItems3 = myInbox3.Items

Set myDestFolder = myInbox.Folders("Da completare")

Set myItem = myItems.Find("[FLAGSTATUS] = 8")
While TypeName(myItem) <> "Nothing"
myItem.Move myDestFolder
Set myItem = myItems.FindNext
Wend

Set myItem = myItems2.Find("[FLAGSTATUS] = 8")
While TypeName(myItem) <> "Nothing"
myItem.Move myDestFolder
Set myItem = myItems2.FindNext
Wend

Set myItem = myItems3.Find("[FLAGSTATUS] = 8")
While TypeName(myItem) <> "Nothing"
myItem.Move myDestFolder
Set myItem = myItems3.FindNext
Wend
End Sub
3 years ago
·
#1757
0
Votes
Undo
Moves Outlook Mail items to a Sub folder by Email address
Option Explicit
Public Sub Move_Items()
'   // Declare your Variables
    Dim Inbox As Outlook.MAPIFolder
    Dim SubFolder As Outlook.MAPIFolder
    Dim olNs As Outlook.NameSpace
    Dim Item As Object
    Dim Items As Outlook.Items
    Dim lngCount As Long
    On Error GoTo MsgErr
'    Set Inbox Reference
    Set olNs = Application.GetNamespace("MAPI")
    Set Inbox = olNs.GetDefaultFolder(olFolderInbox)
    Set Items = Inbox.Items
'   // Loop through the Items in the folder backwards
    For lngCount = Items.Count To 1 Step -1
        Set Item = Items(lngCount)
        If Item.Class = olMail Then
            Select Case Item.SenderEmailAddress
'               // Email_One
                Case ""
'                   // Set SubFolder of Inbox
                    Set SubFolder = Inbox.Folders("Folder One")
                    Set Item = Items.Find("[SenderEmailAddress] = ''")
                    If TypeName(Item) <> "Nothing" Then
'                       // Mark As Read
                        Item.UnRead = False
'                       // Move Mail Item to sub Folder
                        Item.Move SubFolder
                    End If
'               // Email_Two
                Case ""
'                   // Set SubFolder of Inbox
                    Set SubFolder = Inbox.Folders("Folder Two")
                    Set Item = Items.Find("[SenderEmailAddress] = ''")
                    If TypeName(Item) <> "Nothing" Then
'                       // Mark As Read
                        Item.UnRead = False
'                       // Move Mail Item to sub Folder
                        Item.Move SubFolder
                    End If
            End Select
        End If
    Next lngCount
MsgErr_Exit:
    Set Inbox = Nothing
    Set SubFolder = Nothing
    Set olNs = Nothing
    Set Item = Nothing
    Set Items = Nothing
    Exit Sub
'// Error information
MsgErr:
    MsgBox "An unexpected Error has occurred." _
         & vbCrLf & "Error Number: " & Err.Number _
         & vbCrLf & "Error Description: " & Err.Description _
         , vbCritical, "Error!"
    Resume MsgErr_Exit
End Sub
Or to move all Mail items Inbox to sub folder
Option Explicit
Public Sub Move_Items()
'   // Declare your Variables
    Dim Inbox As Outlook.MAPIFolder
    Dim SubFolder As Outlook.MAPIFolder
    Dim olNs As Outlook.NameSpace
    Dim Item As Object
    Dim lngCount As Long
    Dim Items As Outlook.Items
    On Error GoTo MsgErr
'    Set Inbox Reference
    Set olNs = Application.GetNamespace("MAPI")
    Set Inbox = olNs.GetDefaultFolder(olFolderInbox)
    Set Items = Inbox.Items
'   // Loop through the Items in the folder backwards
    For lngCount = Items.Count To 1 Step -1
        Set Item = Items(lngCount)
        Debug.Print Item.Subject
        If Item.Class = olMail Then
'           // Set SubFolder of Inbox
            Set SubFolder = Inbox.Folders("Temp")
'           // Mark As Read
            Item.UnRead = False
'           // Move Mail Item to sub Folder
            Item.Move SubFolder
        End If
    Next lngCount
MsgErr_Exit:
    Set Inbox = Nothing
    Set SubFolder = Nothing
    Set olNs = Nothing
    Set Item = Nothing
    Exit Sub
'// Error information
MsgErr:
    MsgBox "An unexpected Error has occurred." _
         & vbCrLf & "Error Number: " & Err.Number _
         & vbCrLf & "Error Description: " & Err.Description _
         , vbCritical, "Error!"
    Resume MsgErr_Exit
End Sub
3 years ago
·
#1758
0
Votes
Undo
Try the below mentioned code :-
Sub MoveItems7TEST()

Dim myNameSpace As Outlook.NameSpace
Dim myInbox As Outlook.Folder
Dim myInbox2 As Outlook.Folder
Dim myInbox3 As Outlook.Folder

Dim myDestFolder As Outlook.Folder

Dim myItems As Outlook.Items
Dim myItems2 As Outlook.Items
Dim myItems3 As Outlook.Items

Dim myItem As Object

Set myNameSpace = Application.GetNamespace("MAPI")
'Posta in arrivo
Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox)
'Stef
Set myInbox2 = myNameSpace.GetDefaultFolder(olFolderInbox).Folders("Stef")
'Servizio
Set myInbox3 = myNameSpace.GetDefaultFolder(olFolderInbox).Folders("Servizio")

Set myItems = myInbox.Items
Set myItems2 = myInbox2.Items
Set myItems3 = myInbox3.Items

Set myDestFolder = myInbox.Folders("Da completare")

Set myItem = myItems.Find("[FLAGSTATUS] = 8")
While TypeName(myItem) <> "Nothing"
myItem.Move myDestFolder
Set myItem = myItems.FindNext
Wend

Set myItem = myItems2.Find("[FLAGSTATUS] = 8")
While TypeName(myItem) <> "Nothing"
myItem.Move myDestFolder
Set myItem = myItems2.FindNext
Wend

Set myItem = myItems3.Find("[FLAGSTATUS] = 8")
While TypeName(myItem) <> "Nothing"
myItem.Move myDestFolder
Set myItem = myItems3.FindNext
Wend
End Sub

Hope this information helps you.
  • Page :
  • 1
There are no replies made for this post yet.