VBA saving attachments to folders based on file type

[skatonni]

Comment out On Error Resume Next that has no specific purpose, especially while debugging. You will have to write code to handle any errors. One clue that it has a purpose is a nearby On Error Goto 0.

Use Option Explicit. Change your settings to generate Option Explicit automatically.

Dim VariableOfUnknownType ' automatically Variant if you do not know what to put in the "as"

See here for "How to process incoming messages in Microsoft Outlook" http://www.outlookcode.com/article.aspx?id=62

The code is modified for use in a "Run a Script" rule.

Option Explicit

Private Sub SaveAttachments_test()
' open an appropriate mailitem
Dim curritem As MailItem
Set curritem = ActiveInspector.currentItem
SaveAttachments curritem
Set curritem = Nothing
End Sub

Public Sub SaveAttachments(objMsg As MailItem) ' Revised
'Dim objOL As Outlook.Application           ' Not needed. Outlook is "Application" when code is in Outlook
'Dim objMsg As Outlook.MailItem 'Object     ' Not needed. objMsg passed as a parameter

'Dim objAttachments As Outlook.Attachments  ' Code is in Outlook
Dim objAttachments As Attachments           ' Cosmetic edit. Removing "Outlook." does not improve anything

'Dim objSelection As Outlook.Selection      ' Not needed. Processing incoming mailitem

Dim i As Long
Dim lngCount As Long
Dim strFile As String
Dim strFolderpath As String
Dim strDeletedFiles As String

'Dim ns As Outlook.Namespace    ' Code is in Outlook
Dim ns As Namespace             ' Cosmetic edit. Removing "Outlook." does not improve anything

Dim olMoveToFolder As Folder    ' Change your settings to generate Option Explicit automatically
                                ' Added a prefix. Differentiates it from any code named MoveToFolder
                                            
'On Error Resume Next   ' This hides errors you want to fix.
                        ' Do not use unless there is a specific purpose.
                        ' Follow closely with On Error Goto 0.

' Instantiate an Outlook Application object.
'Set objOL = CreateObject("Outlook.Application")    ' Outlook should already be open
Set ns = Application.GetNamespace("MAPI")           ' Application not objOL while in Outlook

' If the folder is directly under the inbox
Set olMoveToFolder = ns.GetDefaultFolder(olFolderInbox).Folders("Excel Imports")

' Get the collection of selected objects.
' Set objSelection = objOL.ActiveExplorer.Selection ' Not needed. Use the item passed as a parameter
' Check each selected item for attachments. If attachments exist,
' save them to the strFolderPath folder and strip them from the item.
' For Each objMsg In objSelection
' This code only strips attachments from mail items.
' If objMsg.class=olMail Then
' Get the Attachments collection of the item.

Set objAttachments = objMsg.Attachments
lngCount = objAttachments.count
strDeletedFiles = ""

If lngCount > 0 Then
    ' We need to use a count down loop for removing items
    ' from a collection. Otherwise, the loop counter gets
    ' confused and only every other item is removed.

    For i = lngCount To 1 Step -1
        'If Right(objAttachments.FileName, 4) = "xlsx" Then
        If Right(objAttachments(i).FileName, 4) = "xlsx" Then   ' Revised
            strFolderpath = "D:\Outlook Rules Test\Excel\"
     
            ' Save attachment before deleting from item.
            ' Get the file name.
            strFile = objAttachments.item(i).FileName

            ' Combine with the path to the Temp folder.
            strFile = strFolderpath & strFile

            ' Save the attachment as a file.
            objAttachments.item(i).SaveAsFile strFile

            'write the save as path to a string to add to the message
            'check for html and use html tags in link
            If objMsg.BodyFormat <> olFormatHTML Then
                strDeletedFiles = strDeletedFiles & vbCrLf & "<file://" & strFile & ">"
            Else
                strDeletedFiles = strDeletedFiles & "<br>" & "<a href='file://" & _
                 strFile & "'>" & strFile & "</a>"
            End If
            'Use the MsgBox command to troubleshoot. Remove it from the final code.
            'MsgBox strDeletedFiles
            Debug.Print strDeletedFiles ' This is less intrusive than MsgBox while debugging.
            
        ElseIf Right(objAttachments(i).FileName, 3) = "csv" Or _
          Right(objAttachments(i).FileName, 3) = "txt" Then
        
            strFolderpath = "D:\Outlook Rules Test\Text\"
             
            Set olMoveToFolder = ns.GetDefaultFolder(olFolderInbox).Folders("Text Imports")
            
            strFile = objAttachments.item(i).FileName
            strFile = strFolderpath & strFile
            objAttachments.item(i).SaveAsFile strFile
            objAttachments.item(i).Delete
            
            If objMsg.BodyFormat <> olFormatHTML Then
                strDeletedFiles = strDeletedFiles & vbCrLf & "<file://" & strFile & ">"
            Else
                strDeletedFiles = strDeletedFiles & "<br>" & "<a href='file://" & _
                 strFile & "'>" & strFile & "</a>"
            End If
            Debug.Print strDeletedFiles
            
        End If
    Next I

    ' Adds the filename string to the message body and save it
    ' Check for HTML body
    If objMsg.BodyFormat <> olFormatHTML Then
        objMsg.body = vbCrLf & "The file(s) were saved to " & strDeletedFiles & vbCrLf & objMsg.body
    Else
        objMsg.HTMLBody = "<p>" & "The file(s) were saved to " & strDeletedFiles & "</p>" & objMsg.HTMLBody
    End If
    
    objMsg.Save
    objMsg.Move olMoveToFolder

 End If
' Next

ExitSub:

Set objAttachments = Nothing
'Set objMsg = Nothing
'Set objSelection = Nothing
'Set objOL = Nothing
    
Set ns = Nothing
Set olMoveToFolder = Nothing

End Sub