VBA to copy mail with attachments

Am trying to write a script to copy email with certain attachment types.

New to VBA for outlook, and running into an issue.

I get an error (Error: (13) Type mismatch) on the line:

"myATT = Item.Attachments"

What am I doing incorrectly?

Code:

---

Public Sub MoveMNS1(Item As Outlook.MailItem)
On Error GoTo PROC_ERR
    Dim myAtt As Outlook.Attachment
   
    myAtt = Item.Attachments
 
        If Right(LCase(myAtt.FileName), 4) = ".msg" Then

            Item.Copy Session.GetDefaultFolder("MNS")
        End If
PROC_ERR:
  MsgBox "Error: (" & Err.Number & ") " & Err.Description, vbCritical
  Debug.Print "Error: (" & Err.Number & ") " & Err.Description
End Sub

---

Thanks for your help.

You have defined myAtt as an attachment not a collection of attachments. You need something like the following - see the comment about the folder location and the additional lines of code. The folder location will depend where the folder is located, but "MNS" is not a valid default folder.

Code:

---

Public Sub MoveMNS1(Item As Outlook.MailItem)
Dim myAtt As Outlook.Attachment
    On Error GoTo PROC_ERR
    For Each myAtt In Item.Attachments
        If Right(LCase(myAtt.fileName), 4) = ".msg" Then
'            Item.Copy Session.GetDefaultFolder("MNS") 'This doesn't appear to be a valid folder location
            ' maybe as follows
            Item.Copy Session.GetDefaultFolder(olFolderInbox).folders("MNS")
            Exit For
        End If
    Next myAtt
    Exit Sub
PROC_ERR:
    MsgBox "Error: (" & Err.Number & ") " & Err.Description, vbCritical
Debug.Print "Error: (" & Err.Number & ") " & Err.Description
End Sub

---

Thanks gmayor.

I modified the code as below:

Code:

---

Public Sub MoveMNS1(Item As Outlook.MailItem)
On Error GoTo PROC_ERR
    Dim myAtt As Outlook.Attachment
    For Each myAtt In Item.Attachments
    myAtt = Item.Attachments
 
        If Right(LCase(myAtt.FileName), 4) = ".msg" Then

            Item.Copy Session.GetDefaultFolder(olFolderInbox).Folders("MNS")
            Exit For
        End If
    Next myAtt
Set myAtt = Nothing
PROC_ERR:
  MsgBox "Error: (" & Err.Number & ") " & Err.Description, vbCritical
  Debug.Print "Error: (" & Err.Number & ") " & Err.Description
End Sub

---

I still get the "Error: (13) Type mismatch"

You have no Exit before the PROC_ERR: so there is always going to be a message box. Remove the On Error line and let's see what the process objects to.

OK, thanks for sticking with me.

I added an exit before the PROC_ERR: but still get the Type Mismatch error.

Code:

---

Public Sub MoveMNS1(Item As Outlook.MailItem)
On Error GoTo PROC_ERR
    Dim myAtt As Outlook.Attachment
    For Each myAtt In Item.Attachments
    myAtt = Item.Attachments
 
        If Right(LCase(myAtt.FileName), 4) = ".msg" Then
           
            Item.Copy Session.GetDefaultFolder(olFolderInbox).Folders("MNS")
            Exit For
        End If
    Next myAtt
Set myAtt = Nothing
GoTo ExitNow
PROC_ERR:
  MsgBox "Error MNS1: (" & Err.Number & ") " & Err.Description, vbCritical
  Debug.Print "Error MNS1: (" & Err.Number & ") " & Err.Description & " at " & Time & " " & Date
ExitNow:
End Sub

---

The following works, assuming your folder path is correct

Code:

---

Public Sub MoveMNS1(Item As Outlook.MailItem)
'Graham Mayor - https://www.gmayor.com - Last updated - 11 Mar 2020
Dim myAtt As Outlook.Attachment
Dim oCopy As Outlook.MailItem

    On Error GoTo PROC_ERR
    If TypeName(Item) = "MailItem" Then
        For Each myAtt In Item.Attachments
            If Right(LCase(myAtt.fileName), 4) = ".msg" Then
                Set oCopy = Item.Copy
                oCopy.Move Session.GetDefaultFolder(olFolderInbox).folders("MNS")
                Exit For
            End If
        Next myAtt
        Set myAtt = Nothing
    End If
    Exit Sub
PROC_ERR:
    MsgBox "Error MNS1: (" & Err.Number & ") " & Err.Description, vbCritical
Debug.Print "Error MNS1: (" & Err.Number & ") " & Err.Description & " at " & Time & " " & Date
End Sub

---