Xtykutl

I am very limited with my VBA skills but I got so far that now I want to finish this project.

I have below VBA code working nicely in my outlook. It saves required email into my drive.

Private WithEvents Items As Outlook.Items



Private Sub Application_Startup()

    Dim olApp As Outlook.Application

    Dim objNS As Outlook.NameSpace

    Set olApp = Outlook.Application

    Set objNS = olApp.GetNamespace("MAPI")

    Set Items = objNS.GetDefaultFolder(olFolderInbox).Items



End Sub



Private Sub Items_ItemAdd(ByVal item As Object)



On Error GoTo ErrorHandler



    'Only act if it's a MailItem

    Dim Msg As Outlook.MailItem

    If TypeName(item) = "MailItem" Then

        Set Msg = item



    'Change variables to match need. Comment or delete any part unnecessary.

        If (Msg.SenderEmailAddress = "noreply@test.com") Or _

        (Msg.Subject = "Smartsheet") Or _

        (Msg.Subject = "Defects") And _

        (Msg.Attachments.Count >= 1) Then



    'Set folder to save in.

    Dim olDestFldr As Outlook.MAPIFolder

    Dim myAttachments As Outlook.Attachments

    Dim Att As String



    'location to save in.  Can be root drive or mapped network drive.

    Const attPath As String = "C:"





    ' save attachment

   Set myAttachments = item.Attachments

    Att = myAttachments.item(1).DisplayName

    myAttachments.item(1).SaveAsFile attPath & Att



    ' mark as read

   Msg.UnRead = False



End If

End If





ProgramExit:

  Exit Sub



ErrorHandler:

  MsgBox Err.number & " - " & Err.Description

  Resume ProgramExit

End Sub

I want to now add the code to move email after its attachment is saved to my Test folder. Test folder is under Inbox in my outlook.

I have added
Set FldrDest = Session.Folders("Address1").Folders("Inbox").Folders("Test")

under Private Sub Application_Startup() and then I added code into my VBA.

Code is after ' mark as read

If .Parent.Name = "Test" And .Parent.Parent.Name = "Inbox" Then

      ' MailItem is already in destination folder

    Else

      .Move FldrDest

    End If

No other changes but it gives me compilation errors.

The MailItem.Move is in fact a function that return the object that has been moved in the new destination.
The old object is kind of "lost", see how to use it (i've commented the deletion part in the whole code ;) )

Set Msg = .Move(FldrDest)

MsgBox Msg.SenderEmailAddress & vbCrLf & Msg.Subject

Full code with some suggestions for improvement (see '--> comments) :

Private WithEvents Items As Outlook.Items



'location to save in.  Can be root drive or mapped network drive.

'-->As it is a constant you can declare it there (and so, use it in the whole module if you want to do other things with it!)

Private Const attPath As String = "C:"





Private Sub Application_Startup()

    Dim olApp As Outlook.Application

    Dim objNS As Outlook.NameSpace

    Set olApp = Outlook.Application

    Set objNS = olApp.GetNamespace("MAPI")

    Set Items = objNS.GetDefaultFolder(olFolderInbox).Items

End Sub



Private Sub Items_ItemAdd(ByVal item As Object)



On Error GoTo ErrorHandler

    'Only act if it's a MailItem

    If TypeName(item) = "MailItem" Then

        Dim Msg As Outlook.MailItem

        '-->Use directly the parameter and keep it under wraps using "With", it'll improve efficiency

        With item

            'Change variables to match need. Comment or delete any part unnecessary.

            If (.SenderEmailAddress = "noreply@test.com" _

               Or .Subject = "Smartsheet" _

               Or .Subject = "Defects" _

               ) _

               And .Attachments.Count >= 1 Then





                Dim aAtt As Outlook.Attachment

                '-->Loop through the Attachments' collection

                for each aAtt in item.Attachments

                    '-->You can either use aAtt.DisplayName or aAtt.FileName

                    '-->You can test aAtt.Size or aAtt.Type



                    'save attachment

                    aAtt.SaveAsFile attPath & aAtt.DisplayName

                next aAtt



                'mark as read

                .UnRead = False



                Dim olDestFldr As Outlook.MAPIFolder

                Set FldrDest = Session.Folders("Address1").Folders("Inbox").Folders("Test")

                If .Parent.Name = "Test" And .Parent.Parent.Name = "Inbox" Then

                    'MailItem is already in destination folder

                Else

                    Set Msg = .Move(FldrDest)

                    MsgBox Msg.SenderEmailAddress & vbCrLf & Msg.Subject

                    'Msg.delete

                End If

            End If

        End With 'item

    End If





ProgramExit:

  Exit Sub



ErrorHandler:

  MsgBox Err.number & " - " & Err.Description

  Resume ProgramExit

End Sub

Easier than I thought. Just added a loop with Msg.Delete.