Automatically Printing/Saving Emails/Attachments in Outlook

Automatically Printing/Saving Emails/Attachments in Outlook

Issue.  One of the more frequent Outlook questions I see here on EE is "How can I automatically save or print an email and/or its attachments?"  There are a number of variations to the basic question.  For example, "How can I save attachments to a specific file system folder?" or "How can I print a message and all its attachments to a specific printer?" or "How can I print a specific type of attachment?" or "My organization places a strict limit on mailbox size.  How can I save attachments to the file system and insert a link to them in the original message thereby saving space in my mailbox?".

Background.  Outlook’s rules wizard does include the "print it" action which will print the message, but will not print the attachments.  If you manually print an item, then you can elect to print the attachments too, but only to the default printer.  The rules wizard does not include an action for saving a message or attachment to the file system, nor saving and replacing attachments with hyperlinks to them.  

Solution.  The solution is to use a bit of scripting, a macro, and a rule to perform the desired actions.  The rule is triggered when an item meeting a given condition arrives.  The rule calls the macro which performs the actual work.  

Until now I’ve handled each question requesting one of these capabilities individually.  That is, I wrote a custom macro to address each author’s specific needs.  If the author wanted to print a given attachment, then I produced a macro that would do just that.  If instead they wanted to save and remove attachments replacing them with hyperlinks in the message itself, then I wrote a macro for that alone.  

Recently I saw another of these questions and decided it was time to put together a macro that would handle almost any of these situations.  This macro has the ability to perform any combination of the following actions:

  a.  Print the message.
  b.  Print the message to a specific printer.
  c.  Save the message to a specific folder in the file system.
  d.  Save the message in a specific format.
  e.  Print all attachments.
  f.  Print only certain types of attachments (e.g. all .doc, .wks, .pdf).
  g.  Print attachments to a specific printer.
  h.  Save attachments to a specific folder in the file system.
  i.  Remove (save and delete) attachments replacing each with a hyperlink to the saved attachment.
      The hyperlinks are inserted at the bottom of the message.

Requirements.  Microsoft Outlook.  The macro should work with any version of Outlook from 2000 on, but I’ve only tested it with 2007.  The instructions assume that you are using Outlook 2007.

Instructions.  Follow these instructions to use this solution.

 

1. Add the Macro to Outlook

  a.  Start Outlook.
  b.  Click Tools > Macro  > Visual Basic Editor.
  c.  If not already expanded, expand Microsoft Office Outlook Objects.
  d.  If not already expanded, expand Modules.
  e.  Select an existing module (e.g. Module1) by double-clicking on it or create a new module
       by right-clicking Modules and selecting Insert  > Module.
  f.  Copy the code below and paste it into the right-hand pane of Outlook's VB Editor window.
  g.  Edit the code as needed.  I included comments wherever something needs to or can change.
  h.  Click the diskette icon on the toolbar to save the changes.
 

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") & "\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, 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

Select all Open in new window

2. Create a Subroutine That Calls the Macro

We can’t call the macro directly from a rule since the macro requires parameters to tell it what actions to take and we can’t pass those parameters from a rule.  Instead you need to create a subroutine of your own that calls the macro and tells it which actions you want it to perform for the given message.  You can create as many subroutines as you need.  Typically you’ll have one subroutine for each set of actions you want to perform.  

For example, assume that you receive messages pertaining to a project you’re working on, we’ll call it Project X, and you receive a daily message from accounting that includes a rather large spreadsheet attachment.  You want to automatically print and save the Project X messages, while for the accounting messages you want to remove the attached spreadsheet and replace it with a hyperlink.  Since the actions are required are different you’d need to create a subroutine for each.  You can create your subroutine(s) in the same module with the other macro code or you can place it in another module.  The decision is yours.  

To create a subroutine:

  a.  Start Outlook.
  b.  Click Tools > Macro  > Visual Basic Editor.
  c.  If not already expanded, expand Microsoft Office Outlook Objects.
  d.  If not already expanded, expand Modules.
  e.  Select an existing module (e.g. Module1) by double-clicking on it or create a new module by
       right-clicking Modules and selecting Insert > Module.
  f.  Copy the code below and paste it into the right-hand pane of Outlook's VB Editor window.
  g.  Edit the code.  At a minimum you must give the subroutine a unique name and you must
       set the parameters.  
  h.  Click the diskette icon on the toolbar to save the changes.

Parameters.
The macro takes a maximum of nine parameters.  In the code below these are represented as P1 through P9.  The parameters are positional (i.e. they must appear in the sequence given).

P1.  Print the message.
Tells the macro to print the email.  Valid values are True or False.

P2.  Save the message.
Tells the macro to save the email to the file system.  Valid values are True or False.

P3.  Print the attachments.
Tells the macro to print the attachments.  Valid values are True or False.

P4.  Save the attachments.
Tells the macro to save the attachments.  Valid values are True or False.

P5.  Remove attachments.
Tells the macro to remove the attachments and insert hyperlinks to  them at the bottom of the message.  Valid values are True or False.

P6. Attachment types.
Tells the macro what attachment types to save/print.  The macro will only process attachments that match the file types.  This parameter is a comma separated list of file extensions.  For example, to only process Word documents (both 2007 and earlier) you’d set this parameter to "doc,docx".

P7. Target file system folder.
This tells the macro which file system folder to save the message and/or attachments to.  Valid values are any existing file system folder, including network shares and UNC paths.  If you’ve told the macro to save the message and/or attachments and you fail to specify this parameter, then the macro will save the items to your My Documents folder.

P8. Message save format.
Tells the macro what format to save the message in (assuming that you are saving the message).  You will be prompted with a list of valid values when you enter this parameter.

P9. Printer name.
Tells the macro what printer to print the message and/or attachments to.  This allows you to print to any printer, not just the default printer.  Valid values include the name of any printer that appears in your list of printers.  If you’ve told the macro to print the message and/or attachments and you don’t specify a printer, then the macro will print them to your default printer.

All the parameters are optional so you can omit those that you don’t need.
 

‘Change MySubroutineName to a unique name on the next line’
                      Sub MySubroutineName(Item As Outlook.MailItem)
                              MessageAndAttachmentProcessor Item, P1, P2, P3, P4, P5, P6, P7, P8, P9
                      End Sub

Select all Open in new window

Examples of Usage

3. Configure Security

  a.  Click Tools > Trust Center.
  b.  Click Macro Security.
  c.  Set Macro Security to Warnings for all macros.
  d.  Click OK.
  e.  Close Outlook.
  f.  Start Outlook.

4. Create a Rule that Triggers the Subroutine

  a.  Click Tools > Rules and Alerts.
  b.  Click the New Rule button.
  c.  Under "Start from a blank rule" select Check messages when they arrive.
  d.  Click the Next button.
  e.  Select a condition for the messages you want to process.  If you want the macro to run against
       all messages, then don’t select a condition.  Outlook will display a dialog-box warning  you
       that "This rule will be applied to every message you receive.  Is this correct?".   Click Yes.
  f.  Click the Next button.
  g.  Place a check in the box next to run a script.
  h.  In the lower pane click the underlined a script.  Select your subroutine as the script to run.
  i.   Work your way through the rest of the Rules Wizard.

Links to Other BlueDevilFan Articles

1. Creating Linked Notes in Outlook 2007
2. Extending Outlook Rules via Scripting
3. Importing and Exporting Outlook 2007 Categories
4. Outlook 2007 Corporate Categories System
5. Avoiding Blank Subject Lines in Outlook
6. Never Again Forget to Add that Attachment to your Outlook Email
7. Enhancing Outlook 2007 Meeting Reminders