Outlook - Automatically Save Attachements for emails with specific subject.

Hi,
I have to come up with a way to save file attachments that come into my inbox.  

The subject, for example, is "Newsletter Email".

I am trying to come up with some type of VB code to put into Outlook's VBA Editor.

I don't want to save the entire .msg file, just the attachment.

It should keep the same name, but append the date.

So if the attachment is "newsletter.pdf" I want to save it as "newsletter 7-14-2014.pdf".

I am not sure where to start, except for the VBA editor.
LVL 1
jsctechyAsked:
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

David LeeCommented:
Hi, jsctechy.

This article I wrote is a good starting point for doing this.  In order to have that solution act on messages with a specific subject, create a rule that triggers on messages with the subject you want to filter on and have it run the macro described in the article.
0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
QlemoBatchelor, Developer and EE Topic AdvisorCommented:
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

Open 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.
0
jsctechyAuthor Commented:
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.
0
Ultimate Tool Kit for Technology Solution Provider

Broken down into practical pointers and step-by-step instructions, the IT Service Excellence Tool Kit delivers expert advice for technology solution providers. Get your free copy now.

jsctechyAuthor Commented:
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.
0
QlemoBatchelor, Developer and EE Topic AdvisorCommented:
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

Open 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

Open 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).
0
QlemoBatchelor, Developer and EE Topic AdvisorCommented:
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.
0
jsctechyAuthor Commented:
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

-----------
0
jsctechyAuthor Commented:
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.
0
QlemoBatchelor, Developer and EE Topic AdvisorCommented:
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 ...
0
jsctechyAuthor Commented:
Thanks.  I chose it.  The file attachment still didn't save.

There are no errors or anything either.
0
David LeeCommented:
@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

Open 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.
0
jsctechyAuthor Commented:
BDF,
I just meant that when I copied from the article,
the line just said Outlook Mailitem, instead of Outlook.Mailitem.
0
jsctechyAuthor Commented:
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
0
jsctechyAuthor Commented:
Also it is worth noting, I'm using Outlook 2013 on Windows 8.1 x64
0
David LeeCommented:
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.
0
jsctechyAuthor Commented:
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.
0
jsctechyAuthor Commented:
Eh- not working... at a loss.

I'm not sure what my code should look like at all now...
0
QlemoBatchelor, Developer and EE Topic AdvisorCommented:
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.
0
jsctechyAuthor Commented:
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
0
jsctechyAuthor Commented:
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

Open in new window

0
QlemoBatchelor, Developer and EE Topic AdvisorCommented:
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"

Open in new window

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

Open in new window

0
jsctechyAuthor Commented:
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?
0
David LeeCommented:
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.
0
QlemoBatchelor, Developer and EE Topic AdvisorCommented:
Not to forget the rule, it needs to be set manually too (or exported into a file and imported).
0
jsctechyAuthor Commented:
Great- thanks guys!
0
jsctechyAuthor Commented:
Great script!
0
QlemoBatchelor, Developer and EE Topic AdvisorCommented:
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?
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
VB Script

From novice to tech pro — start learning today.

Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.