VBA saving attachments to folders based on file type

[dampfleece]

Hello,

Completely new to this and spent a few hours trying various code from the internet, but still not working how I want.

Basically I want to automate some code to continually run on an email inbox. The code should run every time a new mail is received. If there are no attachments on the mail I want nothing to happen.

If there is an xls or xlsx attachment I want the attachment only to be saved in a folder called say D:\Outlook Rules Test\Excel.
The email should then be moved to another outlook folder called 'Excel Imports' with a link to where the file went to appended to the body of the email.

If there is a csv or txt attachment I want the attachment only to be saved in a folder called say D:\Outlook Rules Test\text.
The email should then be moved to another outlook folder called 'Text Imports' with a link to where the file went to appended to the body of the email.

Is this possible??

So far I have fudged through the following which is doing some of the above, but not all of it by any means so any help or advice would be really appreciated!!




Public Sub SaveAttachments()
Dim objOL As Outlook.Application
Dim objMsg As Outlook.MailItem 'Object
Dim objAttachments As Outlook.Attachments
Dim objSelection As Outlook.Selection
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


Set ns = Application.GetNamespace("MAPI")


Set MoveToFolder = ns.Folders("Excel Imports")


strFolderpath = "D:\Outlook Rules Test\Excel\"
On Error Resume Next


' Instantiate an Outlook Application object.
Set objOL = CreateObject("Outlook.Application")


' Get the collection of selected objects.
Set objSelection = objOL.ActiveExplorer.Selection




' 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

' 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

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 MoveToFolder

End If
Next


ExitSub:


Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
End Sub

[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

[ElSnell]

Hi, using Windows and MS Outook 2007, I want to do something similar but in selected emails, not all emails, I have spent some time with these 2 vba codes below trying to combine sections of the 2 unsuccessfully. One successfully saves the specific file type attachment into a folder and the other saves all attachments into a folder and creates a hyperlink in the email. I need to create a macro so when I select an email it will save a specific file type .xlsx into a local folder (not delete the attachment) AND create a hyperlink in the email. can anyone please help combine a part of one or the other to do this?

SAVES A SPECIFIC FILE TYPE INTO A LOCAL FOLDER:

Public Sub RunActions2()
Dim sFldr As String
Dim sExtn As String
Dim Item As Outlook.MailItem
Dim Atmt As Attachment
Dim strFile As String
sFldr = "Z:\Shared Documents\Customer folders\Customer folder\" ' path to folder where you want to save"
sExtn = "xlsx" ' extension to search for
Dim objSelection As Outlook.Selection
Set objSelection = Application.ActiveExplorer.Selection
On Error GoTo errRunActions
For Each Item In objSelection
For Each Atmt In Item.Attachments
If GetExtension(Atmt.FileName) = sExtn Then
Atmt.SaveAsFile sFldr & "" & Atmt.FileName
End If
Next
Next
On Error GoTo 0
Exit Sub
errRunActions:
MsgBox "Error occurred while saving attachments : " & vbCrLf & Err.Description, vbExclamation, "Saving attachments"
End Sub

Private Function GetExtension(f As String)
Dim a As Variant
GetExtension = ""
If InStr(f, ".") > 0 Then
a = Split(f, ".")
GetExtension = a(UBound(a))
End If
End Function


AND THEN THE CODE FOR ADDING A LINK:



Public Sub SaveAttachments()
Dim objOL As Outlook.Application
Dim objMsg As Outlook.MailItem 'Object
Dim objAttachments As Outlook.Attachments
Dim objSelection As Outlook.Selection
Dim i As Long
Dim lngCount As Long
Dim strFile As String
Dim strFileExtension As String


' Instantiate an Outlook Application object.
Set objOL = CreateObject("Outlook.Application")
' Get the collection of selected objects.
Set objSelection = objOL.ActiveExplorer.Selection
strFileExtension = ".xlsx"
' Set the Attachment folder.
strFolderpath = strFolderpath & "Z:\Shared Documents\Customer folders\Customer folder\"

' 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
' 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
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
End If
Next
ExitSub:
Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
End Sub