VBA to copy mail with attachments

[ANDYK1968]

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?


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.

[gmayor]

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.


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

[ANDYK1968]

Thanks gmayor.

I modified the code as below:


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"

[gmayor]

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.

[ANDYK1968]

OK, thanks for sticking with me.

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


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

[gmayor]

The following works, assuming your folder path is correct

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