Learn how to a build a cloud-first strategyRegister Now

x
?
Solved

Outlook - Automatically Save Attachements for emails with specific subject.

Posted on 2014-07-15
27
Medium Priority
?
1,311 Views
Last Modified: 2014-07-17
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.
0
Comment
Question by:jsctechy
  • 15
  • 8
  • 4
27 Comments
 
LVL 76

Accepted Solution

by:
David Lee earned 2000 total points
ID: 40198404
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
 
LVL 71

Expert Comment

by:Qlemo
ID: 40198933
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
 
LVL 1

Author Comment

by:jsctechy
ID: 40199207
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
Microsoft Certification Exam 74-409

Veeam® is happy to provide the Microsoft community with a study guide prepared by MVP and MCT, Orin Thomas. This guide will take you through each of the exam objectives, helping you to prepare for and pass the examination.

 
LVL 1

Author Comment

by:jsctechy
ID: 40199235
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
 
LVL 71

Expert Comment

by:Qlemo
ID: 40199323
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
 
LVL 71

Expert Comment

by:Qlemo
ID: 40199334
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
 
LVL 1

Author Comment

by:jsctechy
ID: 40199349
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
 
LVL 1

Author Comment

by:jsctechy
ID: 40199460
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
 
LVL 71

Expert Comment

by:Qlemo
ID: 40199481
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
 
LVL 1

Author Comment

by:jsctechy
ID: 40199597
Thanks.  I chose it.  The file attachment still didn't save.

There are no errors or anything either.
0
 
LVL 76

Expert Comment

by:David Lee
ID: 40199635
@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
 
LVL 1

Author Comment

by:jsctechy
ID: 40199718
BDF,
I just meant that when I copied from the article,
the line just said Outlook Mailitem, instead of Outlook.Mailitem.
0
 
LVL 1

Author Comment

by:jsctechy
ID: 40199748
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
 
LVL 1

Author Comment

by:jsctechy
ID: 40199833
Also it is worth noting, I'm using Outlook 2013 on Windows 8.1 x64
0
 
LVL 76

Expert Comment

by:David Lee
ID: 40199993
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
 
LVL 1

Author Comment

by:jsctechy
ID: 40200199
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
 
LVL 1

Author Comment

by:jsctechy
ID: 40200283
Eh- not working... at a loss.

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

Expert Comment

by:Qlemo
ID: 40200293
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
 
LVL 1

Author Comment

by:jsctechy
ID: 40200324
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
 
LVL 1

Author Comment

by:jsctechy
ID: 40200327
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
 
LVL 71

Expert Comment

by:Qlemo
ID: 40200347
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
 
LVL 1

Author Comment

by:jsctechy
ID: 40200469
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
 
LVL 76

Expert Comment

by:David Lee
ID: 40200772
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
 
LVL 71

Expert Comment

by:Qlemo
ID: 40200802
Not to forget the rule, it needs to be set manually too (or exported into a file and imported).
0
 
LVL 1

Author Comment

by:jsctechy
ID: 40201839
Great- thanks guys!
0
 
LVL 1

Author Closing Comment

by:jsctechy
ID: 40201841
Great script!
0
 
LVL 71

Expert Comment

by:Qlemo
ID: 40201939
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

Featured Post

Upgrade your Question Security!

Add Premium security features to your question to ensure its privacy or anonymity. Learn more about your ability to control Question Security today.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

With so many activities to perform, Exchange administrators are always busy in organizations. If everything, including Exchange Servers, Outlook clients, and Office 365 accounts work without any issues, they can sit and relax. But unfortunately, it…
Currently, there is an issue with being able to copy values from an external application to a dropdown list in Project Web Access (PWA).  The standard copy and paste methods don't seem to work properly. Here is a way to accomplish this task to s…
To add imagery to an HTML email signature, you have two options available to you. You can either add a logo/image by embedding it directly into the signature or hosting it externally and linking to it. The vast majority of email clients display l…
Have you created a query with information for a calendar? ... and then, abra-cadabra, the calendar is done?! I am going to show you how to make that happen. Visualize your data!  ... really see it To use the code to create a calendar from a q…
Suggested Courses

810 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question