Outlook - Automatically Save Attachements for emails with specific subject.

Above article is a versatile method using rules to trigger actions, but can also used with buttons or in the ItemAdd event handler of MailItem. I prefer the latter, and use a much simpler approach for saving attachments:

' --- Store attachment in predefined folder
Public Sub SaveAttachments(ml As MailItem, loc As String)
Dim i, pos As Integer
Dim fn As String
  Debug.Print "Processing: " & ml.Subject & ": " & ml.Attachments.Count
  With ml.Attachments
    For i = 1 To .Count
      fn = .Item(i).FileName
      pos = InStrRev(fn, ".")
      fn = loc & "\" & Left(fn, pos - 1) & " " & Format(Date, "yyyymmdd") & Mid(fn, pos)
      .Item(1).SaveAsFile fn
    Next
  End With
End Sub

Select allOpen in new window

It is intentionally kept very simple, including no check for existing files. It's called the same way you would call BlueDevilFan's main sub.

Qlemo,
When I paste this into my VBA Editor in Outlook, the script no longer shows up as an option to run the rule with.

The scrip box is blank.

BlueDevilFan,
I'm not familiar with VB or modules.  I've never worked with them before.

Following your instructions, was a bit confusing, but I'll try it again later on.

With my code you will still need something calling the sub, just the same as with BDF's code. For having it available in a rule, you'll need e.g.

Sub SaveNewsletter(Item As Outlook MailItem)
  SaveAttachments Item, "C:\Newsletters"
End Sub

Select allOpen in new window

Now you should have SaveNewsletter in the script choice. Another way is to modify the original sub to use a fixed path, and only have the mail item as parameter:

' --- Store attachment in predefined folder
Public Sub SaveAttachments(ml As MailItem)
Dim i, pos As Integer
Dim fn, loc As String
  loc = "C:\Newsletters"
  Debug.Print "Processing: " & ml.Subject & ": " & ml.Attachments.Count
  With ml.Attachments
    For i = 1 To .Count
      fn = .Item(i).FileName
      pos = InStrRev(fn, ".")
      fn = loc & "\" & Left(fn, pos - 1) & " " & Format(Date, "yyyymmdd") & Mid(fn, pos)
      .Item(1).SaveAsFile fn
    Next
  End With
End Sub

Select allOpen in new window

but that should be used only if you have a single rule calling that procedure (resp. the target folder is always the same).

BTW, you do not need to use modules. You put all code into ThisOutlookSession for starters. Only if you have more complex stuff, and several different tasks to code, modules are useful. As BDF's code consists of several routines, I would definitely put them into an own module, as suggested, to keep them away from your own code.

Okay, I gave it another shot... I must have missed something last time.  The files aren't saving, and I'm not getting any compile errors like I was previously.  Here is my "Module1".

Did I miss something else?  I've read through it 2x.  

---------
Public Declare Function GetProfileString Lib "kernel32" Alias "GetProfileStringA" _
        (ByVal lpAppName As String, ByVal lpKeyName As String, _
        ByVal lpDefault As String, ByVal lpReturnedString As String, _
        ByVal nSize As Long) As Long

Private Declare Function ShellExecute Lib "shell32.dll" _
  Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, _
  ByVal lpFile As String, ByVal lpParameters As String, _
  ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

Sub MessageAndAttachmentProcessor(Item As Outlook.MailItem, _
    Optional bolPrintMsg As Boolean, _
    Optional bolSaveMsg As Boolean, _
    Optional bolPrintAtt As Boolean, _
    Optional bolSaveAtt As Boolean, _
    Optional bolInsertLink As Boolean, _
    Optional strAttFileTypes As String, _
    Optional strFolderPath As String, _
    Optional varMsgFormat As OlSaveAsType, _
    Optional strPrinter As String)
   
    Dim olkAttachment As Outlook.Attachment, _
        objFSO As FileSystemObject, _
        strMyPath As String, _
        strExtension As String, _
        strFileName As String, _
        strOriginalPrinter As String, _
        strLinkText As String, _
        strRootFolder As String, _
        strTempFolder As String, _
        varFileType As Variant, _
        intCount As Integer, _
        intIndex As Integer, _
        arrFileTypes As Variant

    Set objFSO = CreateObject("Scripting.FileSystemObject")
    strTempFolder = Environ("TEMP") & "\"
   
    If strAttFileTypes = "" Then
        arrFileTypes = Array("*")
    Else
        arrFileTypes = Split(strAttFileTypes, ",")
    End If
   
    If bolPrintMsg Or bolPrintAtt Then
        If strPrinter <> "" Then
            strOriginalPrinter = GetDefaultPrinter()
            SetDefaultPrinter strPrinter
        End If
    End If
   
    If bolSaveMsg Or bolSaveAtt Then
        If strFolderPath = "" Then
            strRootFolder = Environ("USERPROFILE") & "\Documents\Attachments"
        Else
            strRootFolder = strFolderPath & IIf(Right(strFolderPath, 1) = "\", "", "\")
        End If
    End If
   
    If bolSaveMsg Then
        Select Case varMsgFormat
            Case olHTML
                strExtension = ".html"
            Case olMSG
                strExtension = ".msg"
            Case olRTF
                strExtension = ".rtf"
            Case olDoc
                strExtension = ".doc"
            Case olTXT
                strExtension = ".txt"
            Case Else
                strExtension = ".msg"
        End Select
        Item.SaveAs strRootFolder & RemoveIllegalCharacters(Item.Subject) & strExtension, varMsgFormat
    End If
       
    For intIndex = Item.Attachments.Count To 1 Step -1
        Set olkAttachment = Item.Attachments.Item(intIndex)
        'Print the attachments if requested'
        If bolPrintAtt Then
            If olkAttachment.Type <> olEmbeddeditem Then
                For Each strFileType In arrFileTypes
                    If (strFileType = "*") Or (LCase(objFSO.GetExtensionName(olkAttachment.FileName)) = LCase(strFileType)) Then
                        olkAttachment.SaveAsFile strTempFolder & olkAttachment.FileName
                        ShellExecute 0&, "print", strTempFolder & olkAttachment.FileName, 0&, 0&, 0&
                    End If
                Next
            End If
        End If
        'Save the attachments if requested'
        If bolSaveAtt Then
            strFileName = olkAttachment.FileName
            intCount = 0
            Do While True
                strMyPath = strRootFolder & strFileName
                If objFSO.FileExists(strMyPath) Then
                    intCount = intCount + 1
                    strFileName = "Copy (" & intCount & ") of " & olkAttachment.FileName
                Else
                    Exit Do
                End If
            Loop
            olkAttachment.SaveAsFile strMyPath
            If bolInsertLink Then
                If Item.BodyFormat = olFormatHTML Then
                    strLinkText = strLinkText & "<a href=""file://" & strMyPath & """>" & olkAttachment.FileName & "</a><br>"
                Else
                    strLinkText = strLinkText & strMyPath & vbCrLf
                End If
                olkAttachment.Delete
            End If
        End If
    Next
   
    If bolPrintMsg Then
        Item.PrintOut
    End If
   
    If bolPrintMsg Or bolPrintAtt Then
        If strOriginalPrinter <> "" Then
            SetDefaultPrinter strOriginalPrinter
        End If
    End If
   
    If bolInsertLink Then
        If Item.BodyFormat = olFormatHTML Then
            Item.HTMLBody = Item.HTMLBody & "<br><br>Removed Attachments<br><br>" & strLinkText
        Else
            Item.Body = Item.Body & vbCrLf & vbCrLf & "Removed Attachments" & vbCrLf & vbCrLf & strLinkText
        End If
        Item.Save
    End If

    Set objFSO = Nothing
    Set olkAttachment = Nothing
End Sub

Function GetDefaultPrinter() As String
    Dim strPrinter As String, _
        intReturn As Integer
    strPrinter = Space(255)
    intReturn = GetProfileString("Windows", ByVal "device", "", strPrinter, Len(strPrinter))
    If intReturn Then
        strPrinter = UCase(Left(strPrinter, InStr(strPrinter, ",") - 1))
    End If
    GetDefaultPrinter = strPrinter
End Function

Function RemoveIllegalCharacters(strValue As String) As String
    ' Purpose: Remove characters that cannot be in a filename from a string.'
    ' Written: 4/24/2009'
    ' Author:  BlueDevilFan'
    ' Outlook: All versions'
    RemoveIllegalCharacters = strValue
    RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, "<", "")
    RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, ">", "")
    RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, ":", "")
    RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, Chr(34), "'")
    RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, "/", "")
    RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, "\", "")
    RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, "|", "")
    RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, "?", "")
    RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, "*", "")
End Function

Sub SetDefaultPrinter(strPrinterName As String)
    Dim objNet As Object
    Set objNet = CreateObject("Wscript.Network")
    objNet.SetDefaultPrinter strPrinterName
    Set objNet = Nothing
End Sub

‘Change MySubroutineName to a unique name on the next line’
Sub Save_The_Files(Item As Outlook MailItem)
        MessageAndAttachmentProcessor Item, , , , True, , "%userprofile%\documents\Attachments\"
End Sub

-----------

I just realized this needed to be corrected:
Sub Save_The_Files(Item As Outlook.MailItem)   (there was no . in there before)
        MessageAndAttachmentProcessor Item, , , , True, , "%userprofile%\documents\Attachments\"
End Sub

But the attachments still aren't saving.

My Outlook rule runs on specific words in the subject "Newsletter Email".

I selected "MessageAndAttachmentProcessor" from the rules wizard...

I think I'm on the right track, but not sure.

In the rule, you need to select the small sub you created, Save_The_Files.
It surprises me that you were able to select MessageAndAttachmentProcessor; because of the optional parameters, the sub should be hidden ...

Thanks.  I chose it.  The file attachment still didn't save.

There are no errors or anything either.

@Qlemo is correct.  You should not be able to select MessageAndAttachmentProcessor as the script to run.  It has optional parameters and procedures that use those aren't allowed to be called from a rule.  The rule should be calling Save_The_Files.  In this example,

Sub Save_The_Files(Item As Outlook.MailItem)   (there was no . in there before)
        MessageAndAttachmentProcessor Item, , , , True, , "%userprofile%\documents\Attachments\"
End Sub

Select allOpen in new window

"%userprofile%" isn't a valid path.  You noted that "this needs to be corrected", but I'm not sure what you corrected.

BDF,
I just meant that when I copied from the article,
the line just said Outlook Mailitem, instead of Outlook.Mailitem.

Thanks for the help, I'm just not sure what I'm missing...  I checked on the script selection (from the rule wizard) and messageattachmentprocessor is still listed.

Could that be the reason it isn't working?  

This is what I have now.

Public Declare Function GetProfileString Lib "kernel32" Alias "GetProfileStringA" _
        (ByVal lpAppName As String, ByVal lpKeyName As String, _
        ByVal lpDefault As String, ByVal lpReturnedString As String, _
        ByVal nSize As Long) As Long

Private Declare Function ShellExecute Lib "shell32.dll" _
  Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, _
  ByVal lpFile As String, ByVal lpParameters As String, _
  ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

Sub MessageAndAttachmentProcessor(Item As Outlook.MailItem, _
    Optional bolPrintMsg As Boolean, _
    Optional bolSaveMsg As Boolean, _
    Optional bolPrintAtt As Boolean, _
    Optional bolSaveAtt As Boolean, _
    Optional bolInsertLink As Boolean, _
    Optional strAttFileTypes As String, _
    Optional strFolderPath As String, _
    Optional varMsgFormat As OlSaveAsType, _
    Optional strPrinter As String)
   
    Dim olkAttachment As Outlook.Attachment, _
        objFSO As FileSystemObject, _
        strMyPath As String, _
        strExtension As String, _
        strFileName As String, _
        strOriginalPrinter As String, _
        strLinkText As String, _
        strRootFolder As String, _
        strTempFolder As String, _
        varFileType As Variant, _
        intCount As Integer, _
        intIndex As Integer, _
        arrFileTypes As Variant

    Set objFSO = CreateObject("Scripting.FileSystemObject")
    strTempFolder = Environ("TEMP") & "\"
   
    If strAttFileTypes = "" Then
        arrFileTypes = Array("*")
    Else
        arrFileTypes = Split(strAttFileTypes, ",")
    End If
   
    If bolPrintMsg Or bolPrintAtt Then
        If strPrinter <> "" Then
            strOriginalPrinter = GetDefaultPrinter()
            SetDefaultPrinter strPrinter
        End If
    End If
   
    If bolSaveMsg Or bolSaveAtt Then
        If strFolderPath = "" Then
            strRootFolder = Environ("USERPROFILE") & "\Documents\Attachments"
        Else
            strRootFolder = strFolderPath & IIf(Right(strFolderPath, 1) = "\", "", "\")
        End If
    End If
   
    If bolSaveMsg Then
        Select Case varMsgFormat
            Case olHTML
                strExtension = ".html"
            Case olMSG
                strExtension = ".msg"
            Case olRTF
                strExtension = ".rtf"
            Case olDoc
                strExtension = ".doc"
            Case olTXT
                strExtension = ".txt"
            Case Else
                strExtension = ".msg"
        End Select
        Item.SaveAs strRootFolder & RemoveIllegalCharacters(Item.Subject) & strExtension, varMsgFormat
    End If
       
    For intIndex = Item.Attachments.Count To 1 Step -1
        Set olkAttachment = Item.Attachments.Item(intIndex)
        'Print the attachments if requested'
        If bolPrintAtt Then
            If olkAttachment.Type <> olEmbeddeditem Then
                For Each strFileType In arrFileTypes
                    If (strFileType = "*") Or (LCase(objFSO.GetExtensionName(olkAttachment.FileName)) = LCase(strFileType)) Then
                        olkAttachment.SaveAsFile strTempFolder & olkAttachment.FileName
                        ShellExecute 0&, "print", strTempFolder & olkAttachment.FileName, 0&, 0&, 0&
                    End If
                Next
            End If
        End If
        'Save the attachments if requested'
        If bolSaveAtt Then
            strFileName = olkAttachment.FileName
            intCount = 0
            Do While True
                strMyPath = strRootFolder & strFileName
                If objFSO.FileExists(strMyPath) Then
                    intCount = intCount + 1
                    strFileName = "Copy (" & intCount & ") of " & olkAttachment.FileName
                Else
                    Exit Do
                End If
            Loop
            olkAttachment.SaveAsFile strMyPath
            If bolInsertLink Then
                If Item.BodyFormat = olFormatHTML Then
                    strLinkText = strLinkText & "<a href=""file://" & strMyPath & """>" & olkAttachment.FileName & "</a><br>"
                Else
                    strLinkText = strLinkText & strMyPath & vbCrLf
                End If
                olkAttachment.Delete
            End If
        End If
    Next
   
    If bolPrintMsg Then
        Item.PrintOut
    End If
   
    If bolPrintMsg Or bolPrintAtt Then
        If strOriginalPrinter <> "" Then
            SetDefaultPrinter strOriginalPrinter
        End If
    End If
   
    If bolInsertLink Then
        If Item.BodyFormat = olFormatHTML Then
            Item.HTMLBody = Item.HTMLBody & "<br><br>Removed Attachments<br><br>" & strLinkText
        Else
            Item.Body = Item.Body & vbCrLf & vbCrLf & "Removed Attachments" & vbCrLf & vbCrLf & strLinkText
        End If
        Item.Save
    End If

    Set objFSO = Nothing
    Set olkAttachment = Nothing
End Sub

Function GetDefaultPrinter() As String
    Dim strPrinter As String, _
        intReturn As Integer
    strPrinter = Space(255)
    intReturn = GetProfileString("Windows", ByVal "device", "", strPrinter, Len(strPrinter))
    If intReturn Then
        strPrinter = UCase(Left(strPrinter, InStr(strPrinter, ",") - 1))
    End If
    GetDefaultPrinter = strPrinter
End Function

Function RemoveIllegalCharacters(strValue As String) As String
    ' Purpose: Remove characters that cannot be in a filename from a string.'
    ' Written: 4/24/2009'
    ' Author:  BlueDevilFan'
    ' Outlook: All versions'
    RemoveIllegalCharacters = strValue
    RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, "<", "")
    RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, ">", "")
    RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, ":", "")
    RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, Chr(34), "'")
    RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, "/", "")
    RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, "\", "")
    RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, "|", "")
    RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, "?", "")
    RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, "*", "")
End Function

Sub SetDefaultPrinter(strPrinterName As String)
    Dim objNet As Object
    Set objNet = CreateObject("Wscript.Network")
    objNet.SetDefaultPrinter strPrinterName
    Set objNet = Nothing
End Sub

' Change MySubroutineName to a unique name on the next line’
Sub Save_The_Files(Item As Outlook.MailItem)
        MessageAndAttachmentProcessor Item, , , , True, , "C:\users\jsctechy\documents\Attachments\"
End Sub

Also it is worth noting, I'm using Outlook 2013 on Windows 8.1 x64

The code should work without any problem in Outlook 2013 and Widows 8.1.  You mention 64-bit.  Is it just Windows that's 64-bit or is Outlook 64-bit also?  That would make a difference.  

The fact that MessageAndAttachmentProcessor shows up as macro in the rule options is a problem and suggests that there's something wrong with the subroutine declaration.  It's as if Outlook isn't seeing the list of optional parameters and sees the declaration as

MessageAndAttachmentProcessor(Item As Outlook.MailItem)

instead of how it's actually declared.

The OS and Office installations are 64bit.

I changed this line:
Public Declare Function GetProfileString Lib "kernel64" Alias "GetProfileStringA" _

Not getting any compile errors now, but still getting seeing all the items listed in the rules wizard.

Eh- not working... at a loss.

I'm not sure what my code should look like at all now...

Really strange. I don't think it is related to 64 vs, 32 bit Outlook (cannot think of any reason for that).

Let's take a different approach:
Make sure the rule calls Save_The_Files.
In VBA Editor, put the cursor on the only line to execute in Save_The_Files, and press F9. This sets a breakpoint.
Apply the rule to at least one newsletter mail (while in the rule management dialog).

VBA should now stop in the line you set the breakpoint on. You can now press F8 to execute the next statement (repeat this to step thru the code), or F5 to continue execution without debugging.

To unset the breakpoint you'll need to again put the cursor into that line and press F9.

Finally got this sorted out- thefiles are saving to "My Documents".

I used the following line, but they don't save to the location I want:
Sub Save_The_Files(Item As Outlook.MailItem)
        MessageAndAttachmentProcessor Item, , , , True, , "C:\Attachments"
End Sub

Option Explicit
Public Declare PtrSafe Function GetProfileString Lib "kernel32" Alias "GetProfileStringA" _
        (ByVal lpAppName As String, ByVal lpKeyName As String, _
        ByVal lpDefault As String, ByVal lpReturnedString As String, _
        ByVal nSize As Long) As Long
    Private Declare PtrSafe Function ShellExecute Lib "shell32.dll" _
  Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, _
  ByVal lpFile As String, ByVal lpParameters As String, _
  ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
    Sub MessageAndAttachmentProcessor(Item As Outlook.MailItem, _
    Optional bolPrintMsg As Boolean, _
    Optional bolSaveMsg As Boolean, _
    Optional bolPrintAtt As Boolean, _
    Optional bolSaveAtt As Boolean, _
    Optional bolInsertLink As Boolean, _
    Optional strAttFileTypes As String, _
    Optional strFolderPath As String, _
    Optional varMsgFormat As OlSaveAsType, _
    Optional strPrinter As String)
   
    Dim olkAttachment As Outlook.Attachment, _
        objFSO As Object, _
        strMyPath As String, _
        strExtension As String, _
        strFileName As String, _
        strOriginalPrinter As String, _
        strLinkText As String, _
        strFileType As Variant, _
        strRootFolder As String, _
        strTempFolder As String, _
        varFileType As Variant, _
        intCount As Integer, _
        intIndex As Integer, _
        arrFileTypes As Variant
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    strTempFolder = Environ("TEMP") & "\"
    
    If strAttFileTypes = "" Then
        arrFileTypes = Array("*")
    Else
        arrFileTypes = Split(strAttFileTypes, ",")
    End If
    
    If bolPrintMsg Or bolPrintAtt Then
        If strPrinter <> "" Then
            strOriginalPrinter = GetDefaultPrinter()
            SetDefaultPrinter strPrinter
        End If
    End If
    
    If bolSaveMsg Or bolSaveAtt Then
        If strFolderPath = "" Then
            strRootFolder = Environ("USERPROFILE") & "\My Documents\"
        Else
            strRootFolder = strFolderPath & IIf(Right(strFolderPath, 1) = "\", "", "\")
        End If
    End If
    
    If bolSaveMsg Then
        Select Case varMsgFormat
            Case olHTML
                strExtension = ".html"
            Case olMSG
                strExtension = ".msg"
            Case olRTF
                strExtension = ".rtf"
            Case olDoc
                strExtension = ".doc"
            Case olTXT
                strExtension = ".txt"
            Case Else
                strExtension = ".msg"
        End Select
        Item.SaveAs strRootFolder & RemoveIllegalCharacters(Item.Subject) & strExtension, IIf(varMsgFormat <> 0, varMsgFormat, olMSG)
    End If
        
    For intIndex = Item.Attachments.Count To 1 Step -1
        Set olkAttachment = Item.Attachments.Item(intIndex)
        'Print the attachments if requested'
        If bolPrintAtt Then
            If olkAttachment.Type <> olEmbeddeditem Then
                For Each strFileType In arrFileTypes
                    If (strFileType = "*") Or (LCase(objFSO.GetExtensionName(olkAttachment.FileName)) = LCase(strFileType)) Then
                        olkAttachment.SaveAsFile strTempFolder & olkAttachment.FileName
                        ShellExecute 0&, "print", strTempFolder & olkAttachment.FileName, 0&, 0&, 0&
                    End If
                Next
            End If
        End If
        'Save the attachments if requested'
        If bolSaveAtt Then
            strFileName = olkAttachment.FileName
            intCount = 0
            Do While True
                strMyPath = strRootFolder & strFileName
                If objFSO.FileExists(strMyPath) Then
                    intCount = intCount + 1
                    strFileName = "Copy (" & intCount & ") of " & olkAttachment.FileName
                Else
                    Exit Do
                End If
            Loop
            olkAttachment.SaveAsFile strMyPath
            If bolInsertLink Then
                If Item.BodyFormat = olFormatHTML Then
                    strLinkText = strLinkText & "<a href=""file://" & strMyPath & """>" & olkAttachment.FileName & "</a><br>"
                Else
                    strLinkText = strLinkText & strMyPath & vbCrLf
                End If
                olkAttachment.Delete
            End If
        End If
    Next
    
    If bolPrintMsg Then
        Item.PrintOut
    End If
    
    If bolPrintMsg Or bolPrintAtt Then
        If strOriginalPrinter <> "" Then
            SetDefaultPrinter strOriginalPrinter
        End If
    End If
    
    If bolInsertLink Then
        If Item.BodyFormat = olFormatHTML Then
            Item.HTMLBody = Item.HTMLBody & "<br><br>Removed Attachments<br><br>" & strLinkText
        Else
            Item.Body = Item.Body & vbCrLf & vbCrLf & "Removed Attachments" & vbCrLf & vbCrLf & strLinkText
        End If
        Item.Save
    End If
    Set objFSO = Nothing
    Set olkAttachment = Nothing
End Sub
    Function GetDefaultPrinter() As String
    Dim strPrinter As String, _
        intReturn As Integer
    strPrinter = Space(255)          'i think this establishes a buffer. Use?
    intReturn = GetProfileString("Windows", ByVal "device", "", strPrinter, Len(strPrinter))          'and this prepares for a dll call, i think. Use?
    If intReturn Then
        strPrinter = (Left(strPrinter, InStr(strPrinter, ",") - 1))
    End If
    GetDefaultPrinter = strPrinter
End Function
    Function RemoveIllegalCharacters(strValue As String) As String
    ' Purpose: Remove characters that cannot be in a filename from a string.'
    ' Written: 4/24/2009'
    ' Author:  BlueDevilFan'
    ' Outlook: All versions'
    RemoveIllegalCharacters = strValue
    RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, "<", "")
    RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, ">", "")
    RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, ":", "")
    RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, Chr(34), "'")
    RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, "/", "")
    RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, "\", "")
    RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, "|", "")
    RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, "?", "")
    RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, "*", "")
End Function
    Sub SetDefaultPrinter(strPrinterName As String)
    Dim objNet As Object
    Set objNet = CreateObject("Wscript.Network")
    objNet.SetDefaultPrinter strPrinterName
    Set objNet = Nothing
End Sub
Sub Save_The_Files(Item As Outlook.MailItem)
        MessageAndAttachmentProcessor Item, , , , True, , "C:\Attachments"
End Sub

Select allOpen in new window

Add a comma before the path - as-is, you are setting the strAttFileTypes instead of strFolderPath. Or use the explicit syntax: Either

MessageAndAttachmentProcessor Item, , , , True, , , "C:\Attachments"

Select allOpen in new window

or

MessageAndAttachmentProcessor Item := Item, bolSaveAtt := True, strFolderPath := "C:\Attachments"

Select allOpen in new window

Thanks a lot guys.  Is there any way to send this file out to specific individuals that need it, or is this a manual process on every PC?

If by "file" you mean the macro, then I'm afraid it's a manual process.  There's no automated way to install macros in Outlook.

Not to forget the rule, it needs to be set manually too (or exported into a file and imported).

Great- thanks guys!

Great script!

Any reason you accepted only BDF's answer? It is common that you assign points to those who helped, splitting the points. No issues with BDF getting the lion's share, but others (= I) resolved an issue in http:#a40200347, and together with other help should receive say 100 points. Do you feel different?