Move Mails

GirishDhruva

Active Member
Joined
Mar 26, 2019
Messages
308
Hi Everyone,
Below i have a code to move all the mails to sub-folder but i am facing an error in highlighted line could any one suggest me why i am facing this error????

Rich (BB code):
Option Explicit


Public Sub Move_Items()
    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
    Dim olApp As Variant
    Dim Mail_Id1 As String
    Dim Mail_Id2 As String
    Dim Filename1 As String
    Dim Filename2 As String
    On Error GoTo MsgErr
    Set olApp = CreateObject("Outlook.Application")
    Set olNs = olApp.GetNamespace("MAPI")
    Set Inbox = olNs.GetDefaultFolder(olFolderInbox)
    Set Items = Inbox.Items
    
    Mail_Id1 = Cells(2, "A").Value
    Mail_Id2 = Cells(3, "A").Value
    
    Filename1 = Cells(2, "C").Value
    Filename2 = Cells(3, "C").Value
    
    For lngCount = Items.Count To 1 Step -1
        Set Item = Items(lngCount)


        If Item.Class = olMail Then
            Select Case Item.SenderEmailAddress
                Case Mail_Id1
                    Set SubFolder = Inbox.Folders(Filename1)
                    Set Item = Items.Find("[SenderEmailAddress] =" & Mail_Id1)
                    If TypeName(Item) <> "Nothing" Then
                        Item.UnRead = True
                        Item.Move SubFolder
                    End If


                Case Mail_Id2
                    Set SubFolder = Inbox.Folders(Filename2)
                    Set Item = Items.Find("[SenderEmailAddress] =" & Mail_Id2)
                    If TypeName(Item) <> "Nothing" Then
                        Item.UnRead = True
                        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


MsgErr:
    MsgBox "An unexpected Error has occurred." _
         & vbCrLf & "Error Number: " & Err.Number _
         & vbCrLf & "Error Description: " & Err.Description _
         , vbCritical, "Error!"
    Resume MsgErr_Exit
End Sub

where users will provide their mail-id in cells A1 and A2 and folder name in cells B1 and B2

Regards
Dhruv
 

Excel Facts

Move date out one month or year
Use =EDATE(A2,1) for one month later. Use EDATE(A2,12) for one year later.

Forum statistics

Threads
1,214,415
Messages
6,119,382
Members
448,889
Latest member
TS_711

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top