<

[Product update] Infrastructure Analysis Tool is now available with Business Accounts.Learn More

x

Automatically Printing/Saving Emails/Attachments in Outlook

Published on
99,232 Points
80,932 Views
23 Endorsements
Last Modified:
Awarded
Community Pick
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 ToolsMacro  > 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

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 ToolsMacro  > 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 InsertModule.
  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

Open in new window


Examples of Usage


You want to print all messages to the default printer.
MessageAndAttachmentProcessor Item, True

You want to print all messages to a non-default printer named "HP Deskjet 3320".
MessageAndAttachmentProcessor Item, True, , , ,,,,,"HP Deskjet 3320"

You want to save all attachments to a folder on your C: drive named "Project X".
MessageAndAttachmentProcessor Item,,,,True,,"C:\Project X"

You want to remove all PDF attachments to a folder on your C: drive named "Accounting" and insert a hyperlink to the saved attachment.
MessageAndAttachmentProcessor Item,,,,True,True,"pdf","C:\Accounting"

You want to print all Word documents to the default printer.
MessageAndAttachmentProcessor Item,,,True,,"doc,docx"

3. Configure Security

  a.  Click ToolsTrust 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 ToolsRules 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
23
Comment
Author:David Lee
  • 120
  • 21
  • 14
  • +45
297 Comments
LVL 10

Expert Comment

by:bromy2004
Its got my Yes.

one point,

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 print the attachments.  Valid values are True or False.

i think P4's Comment is supposed to say Save
0
LVL 76

Author Comment

by:David Lee
@bromy2004:  Oops!  Thanks for pointing that out.  I'll fix it.
0

Expert Comment

by:dbishop1234
For a newbie - have you already answered questions about printing to either specific printer. I tried the code above, but got lost in the process. Thanks
0
Big Business Goals? Which KPIs Will Help You

The most successful MSPs rely on metrics – known as key performance indicators (KPIs) – for making informed decisions that help their businesses thrive, rather than just survive. This eBook provides an overview of the most important KPIs used by top MSPs.

LVL 76

Author Comment

by:David Lee
Hi, dbishop1234.

I'm not sure what you mean by "already answered questions".  I haven't been asked any questions about printing to a specific printer.  Do you have a question about that?  Where did you get lost at in the process?
0

Expert Comment

by:hjvesch
Hi BlueDevilFan,

I don't know what I am doing wrong but I keep errors using your scripts. I followed your guide, but when I execute the macro the line Sub Test(Item As Outlook MailItem)
and I receive an error User defined type not defined.

Thanks, hein
0
LVL 76

Author Comment

by:David Lee
Hi, hjvesch.

Can you post your code so I can see what you're doing?
0

Expert Comment

by:hjvesch
Hi Hi BlueDevilFan,

I attached my code.

Thank you in advance for your feedback.

Hein
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 OlkSaveAsType, _
    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, 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)
    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

Open in new window

0
LVL 76

Author Comment

by:David Lee
That's the article code.  Where's the code you wrote that calls the article code?
0

Expert Comment

by:hjvesch
Please find attached the code to calls the article code.
Sub opslaanmail(Item As Outlook MailItem)
        MessageAndAttachmentProcessor Item, True
End Sub

Open in new window

0
LVL 76

Author Comment

by:David Lee
This line

Sub opslaanmail(Item As Outlook MailItem)

is the problem.  It should be

Sub opslaanmail(Item As Outlook.MailItem)
0

Expert Comment

by:hjvesch
Thank you for your prompt reply.

I made the adjustment and when I try to execute the opslaanmail macro, outlook starts visual basic with this error message: compile error user-defined type not defined and lines 11 till 20 of the first script are marked.
0
LVL 76

Author Comment

by:David Lee
What version of Outlook are you using?
0

Expert Comment

by:hjvesch
I'm using outlook 2007 (dutch version)

I already checked the references (see image) reference
0
LVL 76

Author Comment

by:David Lee
This line

    Optional varMsgFormat As OlkSaveAsType, _

should read

    Optional varMsgFormat As OlSaveAsType, _
 
0

Expert Comment

by:hjvesch
Hi BlueDevilFan,

I made the adjustment and now I get an compile error ser-defined type not defined and this line is marked
, _
        objFSO As FileSystemObject

I can not find the error.

Thanks, Hein
0
LVL 76

Author Comment

by:David Lee
Change FileSystemObject to Object.
0

Expert Comment

by:hjvesch
It works! thanks
0
LVL 76

Author Comment

by:David Lee
You're welcome.
0

Expert Comment

by:fl160
I am a novice in programming and am in urgent need of sequentially printing 900+ Outlook 2007 emails in a specific folder. I also need each email's attachments (including Word, Excel, Tiff, JPG, etc.) to print after  each email.  I have Acrobat Pro and want to print the emails to PDF. I can set the default printer to PDF Printer. I have tried but was unable to change to code for these purposes.  I would very much appreciate if you can modify this code to fit my needs and email it to me or post it here.  If possible, it would be nice for the code to name the output files sequentially as 1.pdf, 2.pdf, etc.

Thank you very much.
0
LVL 76

Author Comment

by:David Lee
Hi, fl160.

Would you mind opening a question for this?  This article really isn't the place to address this.
0

Expert Comment

by:phl1331
Blue Devil,
This is exactly what I was looking for...however, I have never created a macro for outlook just excel.  I must be missing just one thing.  I added the code you had in the original article with module 1 as the article code and module 2 as the parameter code.  I then modified it for what I wanted it to do: print attachments (jpg, jpeg, png) to a specific printer (HP Photosmart D110 series).  Then I set the rule to do this only when coming from a specific email address and run this macro.

Nothing happened.  So I changed it to the most simple code...I copied hjvesch's parameter code and article code just to see if it was my code or something else, then i removed the rule that said a specific person and have it running the macro from all emails...still nothing.

I even tried putting the parameter code above the article code, as you said it could be in the same module, but it just created a bunch of different macros.

Thanks for the help.  Here is my code.
Sub PrintAttach(Item As Outlook.MailItem)
        MessageAndAttachmentProcessor Item, , , True, , , "png,jpg,jpeg,pdf", , , "HP Photosmart D110 series"
End Sub

Open in new window

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 Object, _
        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, 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)
    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

Open in new window

0
LVL 76

Author Comment

by:David Lee
What version of Outlook are you using?  Are you able to run any macros?
0

Expert Comment

by:phl1331
Outlook 2007...whats a simple test to try a macro?
0

Expert Comment

by:phl1331
when i set up rules and select run a script it shows me the one option Project1.PrintAttach
However, when I go Tools>Macro>Macros, it shows none listed
0
LVL 76

Author Comment

by:David Lee
Add this code to that you already have.  Then try and run it by clicking Tools > Macro > Macros and selecting this macro by name.  If it works a dialog-box will pop up telling you that macros are enabled.
Sub TestMacro()
    MsgBox "Macros are enabled."
End Sub

Open in new window

0

Expert Comment

by:phl1331
That worked and it brought me back to Msft Visual Edit...and said Macros in this project are disabled.
0
LVL 76

Author Comment

by:David Lee
Ahh, so macros are disabled.  Add the code below to ThisOutlookSession, then close and restart Outlook.  WHen it restarts you should be asked if you want to enable macros.  Say yes.  You should then see a dialog saying that macros are enabled.  If so, then you should be ready to run the code from this article.
Private Sub Application_Startup()
    MsgBox "Macros are enabled."
End Sub

Open in new window

0

Expert Comment

by:phl1331
Not getting any question about wanting to enable macros...let me make sure i understood you.

I already had module 1 and module 2.  I created module 3 that has this in it
"Sub TestMacro()
    MsgBox "Macros are enabled."
End Sub"

Then i expanded MOO where it shows ThisOutlookSession and in it I put
"Private Sub Application_Startup()
    MsgBox "Macros are enabled."
End Sub"

I saved it closed it, closed outlook and reopened, it opened normal.
0
LVL 76

Author Comment

by:David Lee
Did you follow the article instructions on configuring security?
0

Expert Comment

by:phl1331
Ah yes, after that last response I just reread it and remembered what happened at that step.

My MacroSecurity settings are disabled (by company IT)...I cannot change and it currently is set at "Warnings for signed macros, unsigned disabled"

Is there a way to sign this macro?

Ill try contacting them to change my settings...

Thanks for your help...ill let you know if I have other questions.
0
LVL 76

Author Comment

by:David Lee
Yes, you can sign the macro.  Here's a Microsoft page with instructions on how to do that.  The instructions are for Outlook 2000, but the process is the same in 2007.

http://msdn.microsoft.com/en-us/library/aa155754(office.10).aspx
0

Expert Comment

by:Ksquared_au
This is a fine piece of work.
Wondering if there was a way to identify those that HAVNT been printed. eg mark the ones printed as read, making the other in need of manual intervention, or moving the printed ones to a 'Done' folder.

Great work BDF !
0
LVL 76

Author Comment

by:David Lee
Thanks, Ksquared_au!

Yes, the code can be modified to mark the processed items read or to move them to a folder.  Let me know which you prefer and I'll explain how to make the change to accomplish that.
0

Expert Comment

by:Ksquared_au
Would be sweet if we could do both!
Cheers
0

Expert Comment

by:phl1331
BlueDevilFan,

Sorry about the game last night.

Okay, so I can't run macros, can't selfcert, cant do anything--its all on lockdown. However, I can make a rule to say "run Script". Is there a way to make a script that says print all attachments with .jpg or .png to non-default printer?
0
LVL 76

Author Comment

by:David Lee
Thanks.  Me too.  :-(

If you can't enable macros, then I'm afraid this isn't going to work.  A script is a macro and as you've already determined it isn't able to run.  The only solution I can think of would be to re-write this as an external program that interfaces with Outlook.  
0

Expert Comment

by:Ksquared_au
Sorry to nag BDF......got some news for me??
0
LVL 76

Author Comment

by:David Lee
Ksquared_au,

Thanks for the nag.  I have a bad memory and this had slipped my mind.  Replace the main routine (i.e. MessageAndAttachmentProcessor) with the version below and add the other sub (i.e. OpenOutlookFolder) to the code you already have.  There's a comment line toward the bottom of MessageAndAttachmentProcessor that denotes the two lines of additional code required to do this.  As noted there you have to insert the path to the target folder.  In case you aren't familiar with folder paths in Outlook, here's an explanation of how they work.

A folder path in Outlook is essentially the same as a folder path in the file system.  The one difference being that Outlook folder paths do not include a drive letter.  The path to a folder is a list of all the folders from the root to the target folder with each folder name separated from the preceding folder name by a backslash (i.e. \).  Consider the following folder structure:

Mailbox - Doe, John
    - Calendar
    - Inbox
    - Tasks
Personal Folders
    + Marketing
        + Proposals
        + Reviews
    + Projects
        + Project 1
        + Project 2

The path to "Inbox" is "Mailbox - Doe, John\Inbox".
The path to "Reviews" is "Personal Folders\Marketing\Reviews".

The path to "Project 1" is "Personal Folders\Projects\Project 1".


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, 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

    'Addition for Ksquared_au'
    Item.UnRead = False
    'You must edit the path on the next line'
    Item.Move OpenOutlookFolder("Path_to_the_target_folder")

    Set objFSO = Nothing
    Set olkAttachment = Nothing
End Sub


Function OpenOutlookFolder(strFolderPath As String) As Outlook.MAPIFolder
    ' Purpose: Opens an Outlook folder from a folder path.'
    ' Written: 4/24/2009'
    ' Author:  BlueDevilFan'
    ' Outlook: All versions'
    Dim arrFolders As Variant, _
        varFolder As Variant, _
        bolBeyondRoot As Boolean
    On Error Resume Next
    If strFolderPath = "" Then
        Set OpenOutlookFolder = Nothing
    Else
        Do While Left(strFolderPath, 1) = "\"
            strFolderPath = Right(strFolderPath, Len(strFolderPath) - 1)
        Loop
        arrFolders = Split(strFolderPath, "\")
        For Each varFolder In arrFolders
            Select Case bolBeyondRoot
                Case False
                    Set OpenOutlookFolder = Outlook.Session.Folders(varFolder)
                    bolBeyondRoot = True
                Case True
                    Set OpenOutlookFolder = OpenOutlookFolder.Folders(varFolder)
            End Select
            If Err.Number <> 0 Then
                Set OpenOutlookFolder = Nothing
                Exit For
            End If
        Next
    End If
    On Error GoTo 0
End Function

Open in new window

0

Expert Comment

by:phl1331
Blue Devil fan, the options in form of an msi add-in is very limited..

is there a way to convert this to an add-in for outlook? Im guessing it would have to be changed to an exe then to an msi...any direction as to someone who could do this for me?
0

Expert Comment

by:Ksquared_au
Once again BDF...you are the man! Respect!
0
LVL 76

Author Comment

by:David Lee
phl1331,

An MSI is an installer, not an executable.  Outlook add-ins aren't executables either.  Or at least not when built as a COM add-in (perhaps those written newer tools are).  They are DLLs.  

Yes, this could be re-written as an add-in.  Before thinking about having this done, do the restrictions on your computer permit you to install an add-in?  I'm thinking that if your security/system admin folks have restricted the use of macros, then they are likely to have restricted the use of add-ins too.
0
LVL 76

Author Comment

by:David Lee
Ksquared_au,

Thanks and you're welcome.  If there's anything else I can do, you know where to find me.
0

Expert Comment

by:phl1331
Bluedevil, I have been able to install certain add-ins (ones with msi installer) such as blueprint and autoprint but the issue on those is that they open the image attachments but dont print....the open with microsoft picture viewer and can't print bc it tries to use the photo printer wizard.  microsoft picture viewer isn't even the default for photo editing but somehow it opens with it.  

Long story short, yes i can add certain add-ins
0

Expert Comment

by:phl1331
however, i can't install mapilabs print tools add-in
0
LVL 76

Author Comment

by:David Lee
The people I know that do development work do large scale projects.  I doubt that they'd be interested in something this size and if they were I expect the price would be high (one time development).  There are sites like RentACoder.com where you could possibly find someone to do this.  My concern there is that you'd pay to have something developed and then discover that you can't install it.  It's unclear why your system allows some add-ins to be installed but not others.
0

Expert Comment

by:jayelbird
Do you know how to change the code to be able to save as a pdf for the message save format?
0
LVL 76

Author Comment

by:David Lee
There are a couple of ways to do it, but neither of them are particularly good.  First, the code could be modified to save the messages to Word format, then open them in Word and save them to PDF.  Second, the code can be modified to change the default printer to "Adobe PDF" or a third-party PDF print driver followed by issuing the print command.  The problem with the former is that the process will be kind of slow.  The latter suffers from being prompted for a file name for each message printed.
0

Expert Comment

by:bdonmez
Thanks for the article.
How to print without bringing up the Printer Dialog for html attachments?
0

Expert Comment

by:davidjaziel
Hello BDF,

First off, Thank you for the code, its exactly what i need! Secondly, I'm running into a problem with it. I tested the code for pdf attachments only and it works great. But i recently changed and added for pdf's doc's and docx's to be printed as well and i get an error mesage asking me to debug the code because "cant save attachment" (i dont have the code set to save my attachments). Please help below is the string of code that the script gets hung up on and the rest of my code.

olkAttachment.SaveAsFile strTempFolder & olkAttachment.FileName

Sub PrintAttachmetsDJTM(Item As Outlook.MailItem)
        MessageAndAttachmentProcessor Item, True, False, True, False, False, "pdf,doc,docx", False, False, "\\0330srv02\P0330G"
End Sub

Open in new window

0
LVL 76

Author Comment

by:David Lee
Hi, davidjaziel.

You're welcome.  I'm glad you find it useful.

The code has to save the attachment in order to print it.  Outlook doesn't actually print attachments itself.  Instead, it makes a call to the program registered to handle that type of attachment.  The attachments has to be saved to disk in order for the called program to print it.  The error is telling us that the code can't save the file to the temp folder.  

Looking at the code you posted I see the problem.  It's passing False where the name of the temporary folder goes.  This is causing my code to try and save the attachments to a folder called "False" which, of course, doesn't exist.  Change the code to this and you should be in business.

Sub PrintAttachmetsDJTM(Item As Outlook.MailItem)
        MessageAndAttachmentProcessor Item, True, False, True, False, False, "pdf,doc,docx", , , "\\0330srv02\P0330G"
End Sub                                       

Open in new window

0

Expert Comment

by:jayelbird
Hello again.
I am attempting to use your script, and have set it to automatically go when message get into my inbox, but the prints are not printing the body of the email. The print only has the message's subject and addresses, but the body is coming out blank. Viewing the email after the fact shows the full email.
I am using Outlook 2010.
Any ideas for why this is happening?
0

Expert Comment

by:cilento
Hi BDF,
i have problems when the macro runs because it opens the debug and shows as in the image below. Could you help me?

image that describes what happens when the macro runs. The error dialog is showned
After pressing ok in the error message, the text from "Sub" to "String)" is lighted in yellow. The error message means "compilation error: type defined by user not defined"

That's the final code, written following your instructions. I just did one modification in the subroutine, writing Sub MySubroutineName(Item As Outlook.MailItem) instead of Sub MySubroutineName(Item As Outlook MailItem) (second line)
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, 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)
    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 MySubroutineName(Item As Outlook.MailItem)
        MessageAndAttachmentProcessor Item, False, False, True, False, False, ".pdf"
End Sub

Open in new window

0
LVL 76

Author Comment

by:David Lee
I see the problem.  Change

objFSO As FileSystemObject, _

Open in new window


to

objFSO As Object, _

Open in new window

0

Expert Comment

by:cilento
Thanks BDF,
I changed it. Now the macro is activated by the rule and it doesn't answer error, when activated. Unfortunately, it doesn't print attachements (the are pdf mostly), as requested by setting True parameter P3 in the subroutine.
Maybe I'm not doing all right! Maybe, Have I to specify the address of pdf reader application?
I hope it's possible to get it in working order.
Thanks in advance
Cilento
0
LVL 76

Author Comment

by:David Lee
Hmmm.  No, you don't have to specify the address of the PDF reader application.  The code invokes the application that's registered to handle files with a .pdf extension.  Right-click a PDF file and select print.  If the file prints, then you should be in business.
0

Expert Comment

by:cilento
I'm testing it on MS Office 2010 edition. I'll test on 2007
I'll let you know some news.
Grazie
0

Expert Comment

by:cilento
Definetely the problem was the version. It works perfectly on 2007 edition
Your post is actually so useful, BDF.
Thanks
0
LVL 76

Author Comment

by:David Lee
Thanks and you're welcome!
0

Expert Comment

by:Knottyb
Hey this article is great. Is there a way to get round Windows 7 opening the "photo printer" when the attached is an image? I only ask as this stops the whole process from being automated.

Thanks in advance,

(perhaps in liue of printing direct calling a third party app like i_view32.exe?

"i_view32.exe "attachment" /print"
0
LVL 76

Author Comment

by:David Lee
Thanks, knottyb.

Outlook should always print to the default printer.  Are you saying that it isn't behaving that way for image attachments?
0

Expert Comment

by:mikejoins
BlueDevilFan, you sir are the man! I've just learned about macros and love the thought of customizing Outlook to add efficency to your workload. The first module I have checks to see if the word 'attach' is in your body and then checks to make sure you did indeed attach a file, love that little bit of code!
Now I am trying to figure out how to print all the attachments at once of incoming emails I open. I am getting confused how to execute the macro script, I dont want to make a rule that it checks each incoming email and does it on its own; I want to be able to open the email myself and then click a button to print all the attachements. Could you help a novice out?

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

Open in new window

0
LVL 76

Author Comment

by:David Lee
Hi, mikejoins.

Thanks!

That's simple enough.  This should do it.  Open a message and then run the script PrintAttach.

‘Change MySubroutineName to a unique name on the next line’
Sub PrintAttach()
        MessageAndAttachmentProcessor Application.ActiveInspector.CurrentItem, , , True, P4, P5, P6, P7, P8, P9
End Sub

Open in new window

0

Expert Comment

by:mikejoins
Thanks BlueDevilFan for responding so quick,

I figured how to insert a button that runs the script, but I am getting a "compile error: expected: end of statement" =/
0
LVL 76

Author Comment

by:David Lee
What line is the error occurring on?
0

Expert Comment

by:mikejoins
Ln 6, Col 28...

‘Change MySubroutineName to a unique name on the next line’

it highlights the word "to" in the phrase above
0
LVL 76

Author Comment

by:David Lee
That just a comment so go ahead and delete the line.
0

Expert Comment

by:mikejoins
I deleted the line

Now i get a "compile error: ByRef argument type mismatch" on ln 9, Col 1 on this line...

"MessageAndAttachmentProcessor Application.ActiveInspector.CurrentItem, , , True, P4, P5, P6, P7, P8, P9"

.. P4 is highlighted... I tried to remove all the P#s and then i get a "compile error: expected: expression"  When I replace it with false, then I get a run time error 91
0
LVL 76

Author Comment

by:David Lee
I'm confused on how that can be line #9.  It should be line #2.
0

Expert Comment

by:mikejoins
I had entered bunch of spaces, but now I deleted the spaces. After I rebooted the computer, I reached a new error that was solved in previous posts by another user... something about filesystemobject should be replaced to just object. After I changed the text to just object, i get a new syntax error on line 2 col 99 and it highlights "Sub PrintAttach()" in this code
Sub PrintAttach()
        MessageAndAttachmentProcessor Application.ActiveInspector.CurrentItem, , , True, , , , , ,
End Sub

Open in new window

0
LVL 76

Author Comment

by:David Lee
Did you have a message open when you ran the macro?
0

Expert Comment

by:mikejoins
Morning BDF,

Yah I had the message open, I placed my button to 'print all attachments' in the quickaccess toolbar. Is there any other way to print all attachements with one button click?

My syntax error is highlights 'Sub PrintAttach()'... this is my code in module 2
Sub PrintAttach()
        MessageAndAttachmentProcessor Application.ActiveInspector.CurrentItem, , , True, , , , , ,
End Sub

Open in new window


Could it have something to do with there being more than one printer available to print from? shouldn't it use the default one automatically? Im just confused newb when it comes to coding
0
LVL 76

Author Comment

by:David Lee
Where's the rest of the code (i.e. the MessageAndAttachmentProcessor subroutine)?
0

Expert Comment

by:Nu-Macro-user
Hi BlueDevilFan,

I've never used Macro before and all your notes seem very simple but for some reason they aren't working for me, but maybe it's because I was afraid to alter what you had already typed out.  Am I supposed to make changes to what you wrote and delete the lines in green?  

I have a ton of emails that are going to a folder called "statements" and all these emails have attachments that need to to printed.  Some excel, and the rest are pdf.  I just need for these to all get printed on my say, that way I know when they will go to the printer.

I would really appreciate any help you can give.

Thanks,
0

Expert Comment

by:Nu-Macro-user
I should also mention that I'm using Office 2010
0
LVL 1

Expert Comment

by:ToonCooijmans
BDF,

Thank you for your elaborate description. I've never actually used VBS, and it's really fun to learn something new...

I've got one question. My script compiles, and i can add the script to a rule. When sending a message to Outlook, nothing happens. When i try to manually apply the rule to messages that are already in the inbox, i get the following message:

The script "" doesn't exist or is invalid

When i try to execute a macro, only the TestMacro shows up as a choice. When i execute it, the popup "Macros are Enabled" shows up, indicating macro execution and security checks out...

I've added the main script to Module1, the Parameter Sub to Module2 and the TestMacro (showing nothing more than the popup) in Module3.
0
LVL 76

Author Comment

by:David Lee
Hi, ToonCooijmans.

What's "the Parameter Sub" and "the TestMacro"?
0
LVL 1

Expert Comment

by:ToonCooijmans
My apologies, perhaps i was a bit to fast...

Parameter sub:
Sub PrintAndSaveAttachments(Item As Outlook.MailItem)
        MessageAndAttachmentProcessor Item, False, False, True, True, False, "doc,docx", "C:\Data\PrintAttachements", olDoc, "Canon iR-ADV C2020i"
End Sub

Open in new window

TestMacro:
Sub TestMacro()
    MsgBox "Macros are enabled."
End Sub]

Open in new window


The TestMacro runs fine, but nothing else...
0

Expert Comment

by:joshuaParker
Hi BDF, great work!

I have one question and appreciate if you reply.
I am having tones of emails with attachments, but I need to know which attachment is belong to that e-mail... Can we put something like time stamps on the printed documents? Or can we put e_mail information on the attached documents?

Thank you very much..
0
LVL 1

Expert Comment

by:ToonCooijmans
Great, i got it working running the script manually through the rules dialog (via "Run rules now..."), but it won't run when a new mail arrives.

I've tried the appoach in the topicstart, having the rule execute on all new mail. When this did not work, i changed the rule to execute on certain conditions (subject, sender, etc...) but to no avail.

I'm wondering what this possibly can be, since manual execution does work. Any insights?
0

Expert Comment

by:Scripthunter
Hi BDF

First off thanks a ton for this amazing script, I somehow got this working  but I have a slight problem how about I just want this to print all the email messages with the attachments  and that too in order, eg - Email one Attachment one ...EMail 2 Attachment 2  .. and so on . Simply I want to target the rule on a folder where it would run the script and get the job done also if it could pause for 2-3 seconds between printing each set ( is it too much to ask?) do you think that can be done. Also I dont mind this printing to defualt printer and I  want the file location to save files in the C:\Windows\Temp. The most important is to print the email is exact order with the attachments . Please help
0
LVL 76

Author Comment

by:David Lee
Hi, Scripthunter.

"Email one Attachment one ...EMail 2 Attachment 2  .. and so on"

For the sake of example let's assume there are 50 messages in the folder.  Are you saying that for message #50 the solution would print the 50th attachment to that message?  If so, then it seems odd that each message would have one more attachment than the last message.  If not, then I don't understand the example.  Either way it's going to be a problem.  Outlook triggers the code once for each item that meets the conditions set forth in the rule.  It's not like a single call to a loop that processes the items in the folder one after the other.  I other words, each call is independent and knows nothing about the prior or subsequent calls.
0

Expert Comment

by:Scripthunter
Hello BDF
Thanks for the reply what I am trying to say is this the script is printing the emails and attachments in no order, e.g. it prints first three emails and then it prints their attachments and then it prints the email and its attachment. I am looking to run this on a folder which has 1000s of email and they increse at the rate of another 100 emails per day. So it makes ot really difficult to find what is what from a stack of 500 pages. How this can be sorted out. Even if I get all the emails first and then all the attachments in order still can relate but not a random order.Maybe I am doing something wrong I am not sure, but I am just calling the macro via a rule and using the same exact code. Please review the code below if thats causing the issue.




Sub MySubroutine2 (Item As Outlook.MailItem)
        MessageAndAttachmentProcessor Item,True,FalseTrue,False,False,"pdf",,,""
End Sub



Thanks
0

Expert Comment

by:c2p2ogl
Hello BDF,
You're script/tutorial is awesome!

I can currently save an email to a static folder based on some "trigger" words in the message body.
Now, I want to have the macro find the correct folder to save the email (and attachment) to it based on other words in the email body.

Example:
If the email has "Case 1234" in the body, I want to save it to the "...\Cases\Case 1234" folder on my HDD.
How do I search within "...\Cases", find the appropriate folder ("Case 1234"), and save the email (and attachment separately) there.

Also, (I think you addressed this somewhat above) how do you rename the email based on the date received.

Thanks in advance!
0
LVL 76

Author Comment

by:David Lee
Hi, c2p2ogl.

You wouldn't need to search and find the folder.  You'd pass the path.  All of this would be done in the macro called by the rule.  Something like this

‘Change MySubroutineName to a unique name on the next line’
Sub MySubroutineName(Item As Outlook MailItem)
    If InStr(1,Item.Body,"Case 1234") Then
        MessageAndAttachmentProcessor Item, P1, True, True, P4, P5, P6, "C:\Cases\Case 1234", P8, P9
    Else
        MessageAndAttachmentProcessor Item, P1, True, True, P4, P5, P6, "C:\Cases\Other", P8, P9
    End If
End Sub

Open in new window


This would save all messages with "Case 1234" in the body to the folder "C:\Cases\Case 1234", all other messages would be saved to some other folder.  You'd fill the other parameters in as desired.

Do you want to rename the email to just the date, or do you want to append/prepend the date to the name of the email?
0
LVL 76

Author Comment

by:David Lee
Hi, Scripthunter.

There is no simple way, and perhaps no way at all, to keep the items in sequence.  The problem is that Outlook doesn't print the attachments.  Instead, the code has to make a call to the program registered to handle the attachment file type.  For example, it calls Word to print a Word document.  Unfortunately, the called program doesn't notify the script when it's finished printing so there's no way for the script to know that one item is done and it's time to move on to the next item.  I could add a delay, but that wouldn't solve the problem since there's no way of knowing how long it'll take a given item to print.  A 10 second delay might work for most items, but a longer attachment might take 20 seconds while a short attachment might only take 1-2 seconds.  The longer attachments would still be out of order while the shorter attachments would introduce unnecessary delays.  It might be possible to solve this via the Windows API, but I've not investigated that and I'm sure it won't be simple.
0

Expert Comment

by:c2p2ogl
Hey BDF,

I actually have several hundred "Case####" folders and am receiving multiple emails that need to be "sorted" to the appropriate folder based on the case number listed in the email body. I'd really prefer to not have to hard code each of these individually haha...is there a way the script could find the right folder and drop the email there?

And as for the naming convention, prepending the email subject with the received date & time would be fine.

Thanks for your help!
0
LVL 76

Author Comment

by:David Lee
Hi, c2p2ogl.

You don't have to code the folder names.  For the code to work you're going to have to provide the case numbers to find, or some means of picking the case number out from the rest of the text in the body.  That case number can go in a variable which we can then use to get the right folder the first time.  Searching for the folder is possible, but it requires more code and will slow the macro down each time it runs.  So, is there a foolproof way of picking the case out of the body?  For example, does the body always contain something like "Case 1234"?  If so, is that value always unique?
0

Expert Comment

by:c2p2ogl
Hey BDF,

Oh ok, the variable idea is pretty slick! Yes, MOST times the foolproof way would be to use the specific identifier of the form:  "Case 1234".
However, but I would not say the value is always unique. There are two other instances that sometimes occur:
 
1. The body sometimes contains multiple "Cases" and I need to place a copy of the email in multiple case folders. (i.e. it looks just like this: "Cases 1234, 2345, 3456")
 - Is there a way we could have the script loop for multiple cases if the identifier "Cases" is found and just use the case numbers that follow it as the variables?
 
2. Also, sometimes the same Case number is found at multiple locations throughout the body.
 - Is there a way we could use just the first instance of each unique value so that the same email is not placed in a folder multiple times? (i.e. not use the variable "Case 1234" again if it has already been used earlier for that email)
0
LVL 76

Author Comment

by:David Lee
Hi, ToonCooijmans.

I don't know why the rule isn't firing.  Can you post a screenshot of the rule or synopsize it for me?
0
LVL 76

Author Comment

by:David Lee
Hi, c2p2ogl.

Multiple cases are going to be difficult to pick out unless they are delimited in some way.  I can find a string after the word "Case", but it has to be delimited with something.  Typically that delimiter will be a space.  With multiple cases I don't see a way to know where the string of case numbers ends.
0

Expert Comment

by:BinaryHeretic
In appreciation for this one Expert Exchange answer, I just joined. I am learning VBA, slowly, woven into other projects at work. I googled something like Print outlook attachments and came to this post. For the last few hours, I have tinkered with it. I am in  outlook 2010, 64 bit and needed to answer the "PtrSafe" key word to the a couple elements in the declarations. Then I folowed my way through the questions and answers. Eventually, to my astonishment, it worked. I wil study this code and learn from it. Frankly, it is magical for me. I hope to understand how this macro works. I have, for months, gone repeatedly printed sets of documents and the email--probably 400 emails with three to six attachments, from different programs. Everytime, I thought to myself, I need to automate this, but don't know how to begin. And then this macro. Beautiful. Cool. Thank you for sharing.
0

Expert Comment

by:BinaryHeretic
Hello Blue Devil Fan,
I am using the attachment macro with Outlook 2010, Windows 7. The Windows Picture Viewer pops up and I understand the trigger--it is attempting to print the little graphic addins that accompany an email signature or stationery. For instance, our ISO 9001 certification logo is beneath my name. All the attachmentts and the email print successfully (I am selecting the print options P1 and P3 and designating a printer in P9. I thought one of the PDF's was somehow calling the picture viewer. Nope. In my installation of OL 2010, the picture viewer is summoned in an effort to print the contents of the email, which includes an image file. Can that be excluded from the print command? I presume it falls outside the array index--one more element than it would have expected. It may be seen as a .png file type--not sure. Best case for me: ignore the image inside the email--of course, there might be a time when I need to print that image. Suggestions? Thanks.
0

Expert Comment

by:Squashman
Blue Devil Fan - I'm sorry to hear you're a fan, but you put together one wicked awesome script here.  Going to improve my email use by leaps and bounds.  Thanks!
0
LVL 76

Author Comment

by:David Lee
Hi, Squashman.

*laughing*  Not a Duke fan, huh?  

You're welcome.  Glad you find the script useful.  Thanks for letting me know!
0
LVL 76

Author Comment

by:David Lee
Hi, BinaryHeretic.

Wow, thanks for that!

The simplest way to avoid printing the image you use in your signature is to fill in P6 with the list of file type you do want to print.  Unless you routinely receive messages with graphic file types, then exclude those types of files from the list.  If that won't work for you (i.e. because you do routinely receive graphic attachments that you need to print), then I can show you how to modify the code to avoid hidden attachments.  Images in a signature will always appear as hidden attachments.
0

Expert Comment

by:Squashman
Hey BlueDevilFan,

Sorry, it's all Hoyas for me...

I have a handful of follow up questions that I'm not sure if you've addressed before.

1)  Can you modify the code to insert the "Removed attachments" text and path to file at the top of the email body, as opposed to the bottom?  Sometimes the attachment is with a very long email chain, and I'm looking for a visual clue with the most recent message at the top.

2)  Can the path that is inserted into the message be an actual hyperlink?

3)  Do you know how to create a custom marcro button to put on the Outlook ribbon or quick access toolbar to activate this script on a per-email basis?  For example, instead of using a rule, one could receive the email w/ the attachment, then decide if they want to run that maco by clicking on a button.

4)  Can you modify the file name upon saving?  Add a date/time stamp?  Include the email subject as part of the file name?

5)  Have you come across any way to offer a visual clue that the email had an attachment and was processed per the macro?  This would be in addition to the file name in the body at the bottom, along the lines of question 1 here.  Perhaps the color of the email details line could change, as you can do based on sender?  Or maybe a category could be assigned to that email if this event occurs, and then you can list the category column in your view?

All in all this is awesome.  And thank you for your quick responses!

Squashman
0
LVL 76

Author Comment

by:David Lee
Hi, Squashman.

Georgetown always seems to have a good team.  They used to play Duke regularly.  Come to think of it I don't think they've played in a year or two.  Those were good games.

1.  Yes, that's doable.  Replace lines 126 to 133 with this:

    If bolInsertLink Then
        If Item.BodyFormat = olFormatHTML Then
            Item.HTMLBody = "Removed Attachments<br><br>" & strLinkText & "<br><br>" & Item.HTMLBody
        Else
            Item.Body = "Removed Attachments" & vbCrLf & vbCrLf & strLinkText & vbCrLf & vbCrLf & Item.Body
        End If
        Item.Save
    End If

Open in new window


2.  The code as is already inserts a hyperlink.

3.  What version of Outlook are you using?

4.  The code already adds "Copy (xxx)" to the name of a file if it already exists (where xxx is a number).  If you want to add the date, then change line 99 of the original code to

strFileName = "Copy (" & intCount & ") of " & Format(Date, "yyyy-mm-dd") & " " & olkAttachment.FileName

Open in new window


5.  Using a category would be the simplest and most effective solution.  If you want to go that route, then I can add code that'll do that.

You're welcome!
0

Expert Comment

by:Squashman
Hi BDF,

I may just start to cheer for Duke if you keep up these great responses!

1 - works awesome - thank you

2 - For the link, in my emails it shows up as a text path, not an active hyperlink in the email body that when your mouse is over the path you can click and open that file.  If I just add in "file:///" before the C: path in the code, will that work?

3 - Outlook 2010 - I can use the Developer tab to get a macro button to appear on the toolbar, but just can't seem to link this script to that buton to run at will.  I was thinking i might have a rule that would use this script to save/delete attachments greater than 1MB.  And for smaller attachments I can decide once I've reviewed the email, and then just click this macro button to run it as it wouldn't have been subjected to the rule.

4 - works awesome - thank you

5 - category sounds great - if you can advise on the code, thank you.

Thanks again,
Squashman
0

Expert Comment

by:Squashman
Hi BDF - for question 2 above re: the hyperlink, I realized that it does work if the format of the email is HTML.  Can this be done if it's Rich Text or Plain Text?
Thanks.
0
LVL 76

Author Comment

by:David Lee
2.  I think I can manage adding a link for plain text.  I'm not sure about Rich Text.  Rich Text is much more difficult to deal with and I tend to avoid it like the plague.

3.  You can add a button to the ribbon or add a link on the QAT (quick action toolbar).  Which do you prefer?

5.  Let me think about how best to add a category.
0

Expert Comment

by:Squashman
2 - ok.  at least i understand now, so even if non-html options are possible, this is still phenomenal.

3 - i think the ribbon would be better as it's more visible.

5 - thank you
0
LVL 76

Author Comment

by:David Lee
Hi, Squashman.

This version implements all the changes you requested.  Please replace the code you have now with this version.  You will need to change the category name to one of the categories in your master list.

Follow the instructions on this page to add a button to the ribbon.

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

'On the next line change the name of the category that will be assigned to messages that had attachments processed (printed or saved)
Const MY_CATEGORY = "Processed"

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, _
        intAttachmentsSaved As Integer, _
        arrFileTypes As Variant, _
        bolHiddenAttachment As Boolean, _
        bolCategorize

    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)
        bolHiddenAttachment = IsHiddenAttachment(olkAttachment)
        'Print the attachments if requested'
        If Not bolHiddenAttachment Then
            If bolPrintAtt 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&
                        bolCategorize = True
                    End If
                Next
            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 " & Format(Date, "yyyy-mm-dd") & " " & olkAttachment.FileName
                    Else
                        Exit Do
                    End If
                Loop
                olkAttachment.SaveAsFile strMyPath
                intAttachmentsSaved = intAttachmentsSaved + 1
                bolCategorize = True
                If bolInsertLink Then
                    If Item.BodyFormat = olFormatPlain Then
                        strLinkText = strLinkText & Chr(34) & "file://" & strMyPath & Chr(34) & vbCrLf
                    Else
                        strLinkText = strLinkText & "<a href=""file://" & strMyPath & """>" & olkAttachment.FileName & "</a><br>"
                    End If
                    olkAttachment.Delete
                End If
            End If
        End If
    Next
    
    If bolPrintMsg Then
        Item.PrintOut
    End If
    
    If bolCategorize Then
        If Len(Item.Categories) = 0 Then
            Item.Categories = MY_CATEGORY
        Else
            Item.Categories = Item.Categories & "," & MY_CATEGORY
        End If
        Item.Save
    End If
    
    If bolPrintMsg Or bolPrintAtt Then
        If strOriginalPrinter <> "" Then
            SetDefaultPrinter strOriginalPrinter
        End If
    End If
    
    If bolInsertLink And (intAttachmentsSaved > 0) Then
        If Item.BodyFormat = olFormatHTML Then
            Item.HTMLBody = "Removed Attachments<br><br>" & strLinkText & "<br><br>" & Item.HTMLBody
        Else
            Item.Body = "Removed Attachments" & vbCrLf & vbCrLf & strLinkText & vbCrLf & vbCrLf & Item.Body
        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
                                    
Function IsHiddenAttachment(olkAtt As Outlook.Attachment) As Boolean
    ' Purpose: Determines if an attachment is a hidden attachment.
    ' Written: 7/12/2012
    ' Author:  David Lee
    ' Outlook: 2007 and later
    Const PR_ATTACH_CONTENT_ID = "http://schemas.microsoft.com/mapi/proptag/0x3712001E"
    Dim olkPA As Outlook.PropertyAccessor, varTemp As Variant
    On Error Resume Next
    Set olkPA = olkAtt.PropertyAccessor
    varTemp = olkPA.GetProperty(PR_ATTACH_CONTENT_ID)
    IsHiddenAttachment = (varTemp <> "")
    On Error GoTo 0
    Set olkPA = Nothing
End Function

Open in new window

0

Expert Comment

by:Squashman
Hey Blue Devil Fan,

Thank you again!  However, I'm running into some errors, mostly around the "hidden" portion.  Below is the code I was using right before and things worked right.

Thanks,
Squashman
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 Object, _
        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, 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 " & Format(Date, "yyyy-mm-dd") & " " & 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 = "Removed Attachments<br><br>" & strLinkText & "<br><br>" & Item.HTMLBody
        Else
            Item.Body = "Removed Attachments" & vbCrLf & vbCrLf & strLinkText & vbCrLf & vbCrLf & Item.Body
        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

Sub TEST(Item As Outlook.MailItem)
        MessageAndAttachmentProcessor Item, , , , True, True, , "C:\Users\**********\Documents\OLAttachments\"
End Sub

Open in new window

0
LVL 76

Author Comment

by:David Lee
What are the errors?  Also, I don't see the IsHiddenAtachment function in your code.  Did you copy it?
0

Expert Comment

by:Squashman
In the original code using the above portions I never had any reference to "hidden".  With the most recent version, VBA highlighted those spots as errors to debug.  Once I deleted any reference to hidden portions, the errors went away.  I have replaced the modifications with what i most recently posted here and the script works again, less the enhancements.
0
LVL 76

Author Comment

by:David Lee
Unless you're using Outlook 2003 or earlier, then the code I posted this morning should work.  If it doesn't, then I need to know exactly what the errors are in order to figure out why.  So, please completely replace whatever code you were using before with the code I posted this morning and try it out.  If there's an error, then please share the error with me and I'll see if I can figure out what's going on.

I replaced part of the code from the original article with a more effective method of detecting hidden attachments.  In Outlook graphics that appear in a signature are hidden attachments.  You don't want them printing or saving.  The method I used in the original code was the only method available in Outlook 2003 and earlier.  With Outlook 2007 and later there's a much more effective method available, and I used it in the code I posted this morning.
0

Expert Comment

by:Squashman
Ok, I went back in and compared side by side, now things are looking good.  It saves, deletes, inserts comment at top of email w/ link, and makes the category!

The only thing I'm working on now is the macro button on the ribbon.  I don't see this script in the list of macros available to assign to that command button.
0

Expert Comment

by:Squashman
Great point on hidden attachments and signatures.

First error:
 Compile error: User-defined type not defined
 Lines 25-26
 Current text: objFSO As FileSystemObject, _
 When changed to just Object, it works

And actually, now it works like a charm!  So I do have to add in the follow part to the code at the very bottom in order for Outlook to even detect the script when setting up the rule.

Sub TEST(Item As Outlook.MailItem)
        MessageAndAttachmentProcessor Item, , , , True, True, , "C:\Users\***********\Documents\OLAttachments\"
End Sub

Where the ********** is actually a person email folder name.



So, now it's just all working awesome and now trying to get the ribbon button to work.  This script won't show up in the list of macros.
0
LVL 76

Author Comment

by:David Lee
You'll have to create a new macro that calls this one.  You can't call a macro that takes parameters directly.  Something like this.  This macro would call the routine once for each selected message.  You'll need to fill the parameters out.

‘Change MySubroutineName to a unique name on the next line’
Sub MySubroutineName()
    Dim olkMsg As Outlook.MailItem
    For Each olkMsg in Application.ActiveExplorer.Selection
        MessageAndAttachmentProcessor olkMsg, P1, P2, P3, P4, P5, P6, P7, P8, P9
    Next
End Sub

Open in new window

0

Expert Comment

by:Squashman
HOLY COW YOU ARE AMAZING!!!!!!!!!!!!!

Everything works ridonculously perfect now.  I can't thank you enough.

Saves, deletes, inserts comment, generates category, and includes a case by case button for items not addressed by the rule.

Wish you could sell this as a product - you'd be rich.

Thanks - GO DUKE!!!!!!!!!!!!!!!!
0

Expert Comment

by:Squashman
Hey BDF,

For line 99 above, can you modify this string for the file name to include the subject of the email?

strFileName = "Copy (" & intCount & ") of " & Format(Date, "yyyy-mm-dd") & " " & olkAttachment.FileName

Thanks,
Squashman
0

Expert Comment

by:Squashman
I'm having an issue with trying to save a .pdf - error on line 102

                strFileName = olkAttachment.FileName

I tried adding this extension into the above list around line 78 as

            Case olPDF
                strExtension = ".pdf"

Any thoughts?
0

Expert Comment

by:Squashman
alright, so it's the file name of the attachment.

i resaved the pdf and it worked.

what about this filename would cause an error?

"CC-2013-00148 pic.pdf"
0

Expert Comment

by:Squashman
ok, actually it works even with that file name.  this works with the rule.  but not with the macro button on the ribbon bar.  does something in that script need to change?

here's the ribbon code

Sub AttachmentTest()
    Dim olkMsg As Outlook.MailItem
    For Each olkMsg In Application.ActiveExplorer.Selection
        MessageAndAttachmentProcessor olkMsg, , , , True, True, , "C:\Users\********\Documents\OLAttachments\"
    Next
End Sub
0
LVL 76

Author Comment

by:David Lee
How is it not working (e.g. nothing happens when you click the button, you get an error)?

Just to be sure, the button on the ribbon is calling AttachmentTest, correct?  In other words, you created AttachmentTest in the VB editor, then added the button to the ribbon and set it run AttachmentTest.
0

Expert Comment

by:Squashman
Not sure.  It's not consistent.  If I send myself an email now, then click on the button, it works perfect.  I'm trying to use the button on an email I received previously with an attachment.

When I click on the button then, I get the VBA run time error

 '-37732347 (fdc04005)': Outlook cannot perform this action on this type of attachment

When I click on Debug, it takes me to around line 102 and highlights the text

                strFileName = olkAttachment.FileName

Does this make sense?
0

Expert Comment

by:Squashman
alright.  so i went back into an old email folder and tried a very similar email, same type of attachment, same file name, but it was from a different sender.

i don't think it's the sender, but maybe how they've inserted the attachment into the file?

in the one that doesn't work, the attachment is in the body.  in the one that does work, the attachment is not an icon within the body, rather attached above as a tab next to the message tab.

i was thinking it was a rich text vs html issue, but that works fine in other examples.

alright, so it looks like it's only from this one sender when they send it rich text.  when they send it html, it's fine. and from any other sender, html or rich text works perfect.  thoughts??
0

Expert Comment

by:Squashman
and i just noticed something.  when it's a HTML email, and you run the script, it converts the email to rich or plain text once it adds in the removed attachment text.  does this make sense?
0

Expert Comment

by:Squashman
forget that last post, not sure if that's the case.  doesn't always do that.  i think it depends on the original format.

i know you mentioned that things besides html can cause issues.  should we update the code to just normally run html and do "else" for plain text or rich text.

this would edit lines around 115-120 in your original above:

 If bolInsertLink Then
                    If Item.BodyFormat = olFormatPlain Then
                        strLinkText = strLinkText & Chr(34) & "file://" & strMyPath & Chr(34) & vbCrLf
                    Else
                        strLinkText = strLinkText & "<a href=""file://" & strMyPath & """>" & olkAttachment.FileName & "</a><br>"
                    End If
                    olkAttachment.Delete
0
LVL 76

Author Comment

by:David Lee
"When I click on the button then, I get the VBA run time error

 '-37732347 (fdc04005)': Outlook cannot perform this action on this type of attachment

When I click on Debug, it takes me to around line 102 and highlights the text

                strFileName = olkAttachment.FileName

Does this make sense? "

I'm afraid it doesn't.  Outlook isn't performing any action on that line.  It's retrieving the name of the file.  I don't see how that could product an error.  Even if the file didn't have a name that wouldn't cause a problem.  What's the name of the file it's erroring on?
0

Expert Comment

by:Squashman
It seems somewhat random.  An example file name would be:

CC-2013-00113 temp data.pdf

It seems it's the message type, or how the attachment is inserted into the body of the email.  But only from this one sender.  Other senders, or not inserted into the body, rather attached, works fine.
0
LVL 76

Author Comment

by:David Lee
So the message that are causing the error are all in rich text format.  Is that correct?
0

Expert Comment

by:Squashman
Unfortunately, I can't be for sure of that.  Because it works fine in other situations, regardless of format.

I think it's confined to this very specific scenario, which I don't expect to encounter often.  So all is good right now.

Thank you so very much!  I'll keep in touch and look out for more awesome stuff from Blue Devil country.
0
LVL 76

Author Comment

by:David Lee
You're welcome.  Maybe Duke and the Hoyas will meet in the Big Dance.
0
LVL 1

Expert Comment

by:TPAMisfit
BlueDevilFan,
   I am a newbie to coding. I am trying to get your code to print a txt attachment after the e-mail has already been sent to a specific folder via the Rules. When I try to run the rule with the Parameters for printing a specific attachment I get an error. The error is "The script "" doesn't exisit or is invalid. I am attaching the code:
‘Change MySubroutineName to a unique name on the next line’
Sub PrintAttachment(Item As Outlook.MailItem)
        MessageAndAttachmentProcessor Item, , , True, , , "txt"
End Sub
 
Any help would be greatly appericated.
0
LVL 76

Author Comment

by:David Lee
Hi, TPAMisfit.

Can you post a screen shot of the rule?
0
LVL 1

Expert Comment

by:TPAMisfit
This system won't let me paste a screen shot so I am attacting a file with the screen prints.
Outlook-Rule.docx
0
LVL 76

Author Comment

by:David Lee
The rule looks good.  I created an identical rule and it worked without a problem.  As a test, how about eliminating the move to folder from the rule and see if that makes any difference?
0
LVL 1

Expert Comment

by:TPAMisfit
I did remove that step in the rule but it still throws that error. I am using your original code snippet along with the parameter macro I included earlier.
Thanks
0
LVL 76

Author Comment

by:David Lee
Then I'm not sure what the problem is.  Try changing "PrintAttachment" to "Test" and see if that makes any difference.  You'll need to change the name in the code first, then change the rule to run that macro.
0
LVL 1

Expert Comment

by:TPAMisfit
Eureka! We kept making changes along the script, but never restarted Outlook. Once we did, we received the Compiler error noted above, made the correction as you stated (restarted Outlook!) and it worked perfectly. I owe you points....
0
LVL 76

Author Comment

by:David Lee
Cool!  Glad it's working.
0

Expert Comment

by:BinaryHeretic
Surprise loss of function today:
BDF, been using the macro for a week or so and all has worked perfectly, especially since specifying the file formats to print in parameter 6 (eliminated disruptive attempt to print hidden .png files in email address). Today, I launched the macro but the printer designation  for each program called did not change. I required that the printout go to "\\WASHINGTON\HP LaserJet 4250 PCL5e" but today, the printed attachments were sent to whatever printer was the currently designated printer for that application--for example, the .pdf files went to "send to OneNote" virtual printer and the .xls went to a pdf creator.
I have changed nothing in any portion of the macro--not the subroutine, not the calling macro).
I made one change, unrelated to this macro...but related to office automation. We use ERP software that allows a user to email a link to a document to another user. When that link is clicked, the screen the sending user was viewing opens automatically. I changed the specification of the location of the executables from a mapped drive designation ("c:/intel/da da da/x.exe) to an ip style address (192.2.dadada/x.exe). I see no connection. Ofice was not part of the reassignment. I mention only if it might be relevant.
Thanks for any help.
Eli Becker
Cleveland. OHIO
0

Expert Comment

by:BinaryHeretic
Added insight: I closed the pdf program (ADOBE PRO x) and made no change to the printer selected in ADOBE PRO. When I executed the macro again, with the pdf program closed, the printouts went to the macro specified printer--at least that's what i think happened.

On another note: one document I frequently print is an Excel Spreadsheet with two worksheets filled with data. Currently only the worksheet last used (with focus, apparently?) gets printed.
How might I print all worksheets that are non-blank?
Thanks.
Eli Becker
Cleveand, OH.
0

Expert Comment

by:BinaryHeretic
Ignore my "insight".
The problem persists--no change to the previously assigned printer.
I must have manually changed the printers to "\\WASHINGTON\HP LaserJet 4250 PCL5e" (effectively) and then forgotten my action. The macro seems unable to redesignate the printer. Closed all called applications after resetting them to "send to onenote" printer and the macro attempted to print attachments to onenote. No redesignation of the printer.
Thoughts?
Thanks!
E becker
0

Expert Comment

by:BinaryHeretic
The printer behavior that I describe above was caused by the line in the code that changes the description of the designated printer to all Upper case, line 145
 strPrinter = UCase(Left(strPrinter, InStr(strPrinter, ",") - 1))
I noticed in the watch window that the string for the printer no longer matched the string for the printer as shown in the wsh environment. The WSH displayed the printer as upper and lower case while line 145 transformed that string into all upper case.
I removed the Ucase command and the designated printer, with mixed case type, is now summoned.,overriding the setting of the program prior to running the macro. For example, if my pdf reader/printer is set to print to pdfcreator it now prints to "\\WASHINGTON\HP Laserjet 4250 PCL5e"  where before, with the UCase command, the program could not find the printer. That's my current theory.
Is there a necessity for the strPrinter to be all upper case?
Thanks.
Eli Becker
0
LVL 76

Author Comment

by:David Lee
Hi, Eli.

No.  But I don't see how line 145 could be the problem.  It's setting the default printer back to what it was before the macro changed it to the printer you asked it to print to.  I can see how that might prevent the original default printer from being restored, but not how it could prevent the macro from printing to the correct printer.
0

Expert Comment

by:BinaryHeretic
BDF:
The printer designation problem, for me, remains unresolved. The macro prints to the last printer used by the program, rather than the printer designated in parameter 9.
I am providing the macro that passes the parameters to the larger macro and a jpeg showing the result of the failure to reassign the printer to my selected, parameter 9 printer. The jpeg shows the printer queue of pdf's waiting to print to the virtual printer "pdfcreator". I will try any experiments suggested. When it works for me, this macro is like a custom piece of software and others at our shop are interested in it...but when I demo and the pdfcreator printer is summoned, the value of the macro is not so clear. Not magic; logic. But where?

Sub PrintAttach()
        MessageAndAttachmentProcessor Application.ActiveInspector.CurrentItem, True, , True, , , "pdf,xls,xlsx,doc,docx,msg,html", , , "\\WASHINGTON\HP Laserjet 4250 PCL5e"
        End Sub
        

Open in new window


Thank you for the consultation. I am eager to see where I have gone astray.
Eli Becker
0
LVL 76

Author Comment

by:David Lee
Eli,

I know the printer portion of the code works, so there must be something about that printer.  Does the printer appear with that name (i.e. \\WASHINGTON\HP Lasertjet 4250 PCL5e) in your list of printers?
0

Expert Comment

by:BinaryHeretic
Thanks for the prompt response.
Four programs are called to print the attachments and there are slight variations in the naming of the printer dependent on the program:
Outlook  and Excel 2010 for the .:
HP LaserJet 4250 PCL5e on Washington
Nitro PDF
\\WASHINGTON\HP LaserJet 4250 PCL5e
PDFCreator is not intended to be a printer, but it gets called if it was the default printer for a program prior to running the macro. PDFcreator, in my configuration, has only one printer designated and that is "pdfcreator on null:"
The pdfcreator seems to be the stumbling block.
Thanks for any comments.
Eli
0
LVL 76

Author Comment

by:David Lee
I don't understand.  Why would there be any variation in the name of the printer?  The code is setting the default printer system wide.  However the printer names appears in Devices and Printers is the name you should use in the code.  

Add this code to what you already have.  Change the name of the printer in the code below.  Be sure to choose something other than your current default printer.  Now, open Device and Printers and note which printer is set as the default.  Run the code below.  You should see the default printer switch from whatever it was to whatever printer you set below.  If you print from a program, any program, then the output should go to the default printer unless the program you're printing from doesn't honor the system default for some reason.

Sub TestSDP()
    SetDefaultPrinter "Some Printer Name"
End Sub

Open in new window

0

Expert Comment

by:BinaryHeretic
BDF:
I executed the macro and observed its effect on the system default. I attach three screen shots showing the status of the default system printer before and after macro and the unchanged state of the printer for MS Outlook 2010.

I will try some other combinations and see if I find a pattern. I am also puzzled by this fact: so many users for whom the code works without a hitch, and then me...a black swan.
Thanks for persisting.
Eli
0

Expert Comment

by:BinaryHeretic
BDF,
I have watched the variables in the local window and even though the default printer is designated by the macro to be a physical printer "\\washington....hp..." in my most recent run, all of the .pdf attachments went to "pdfcreator" which, as a test, I had set as the original system default. I attach a screen shot of the print queue on the vitrual printer "pdfcreator" that is halted, waiting for responses. Of course, I did not want to turn my pdf's into other pdf's , I wanted them to queue to the HP printer. An excel worksheet and an MS outlook messsage printed to the programmatically designated printer (the HP) but not the pdfs! I am befuddled (from the verb "To Fudd", a state of confusion that results from matching wits with an overpowering adversary....Rabbit season, Duck Season, Rabbit Season, Duck Season, Duck Season...blam-Daffy has just been befuddled....but I digwess).

I will post the code. Perhaps I have made a small error that undoes the printer desgination.
Thanks for any help and if I can provide more useful information, please ask.--On a separate topic: is there a method to print all worksheets in an attached workbook that are not blank using this script or some additional piece of vba (thank you).
Eli Becker
0

Expert Comment

by:BinaryHeretic
The code to launch the larger script on command (i use command rather than an Outlook rule
Sub PrintAttach()
        MessageAndAttachmentProcessor Application.ActiveInspector.CurrentItem, True, , True, , , "pdf,xls,xlsx,doc,docx,msg,html", , , "\\WASHINGTON\HP LaserJet 4250 PCL5e"
        End Sub

Open in new window


And here is the code copied from your post, including the two or three corrections to your own work that you noted. Also, because I am in Windows 7, I inserted, without understanding its signficance, the "PtrSafe" qualifier in the Public Declarations --I was so instructed in response to compile errors caused either by Windows 7/ 64 bit or Office 2010--one of the two invoked the change:

 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 

Open in new window

0
LVL 76

Author Comment

by:David Lee
Eli,

I don't see any of the attachments mentioned in your comments.  

So, it's only the PDFs that are going to the wrong printer.  All the other file types are going to the printer you set in the code.  Correct?  If so, then the problem has to be with PDF Creator.  It must be overriding the default printer somehow.  The printing of attachments is handled by the command on line 85.  That command invokes the program that's registered to handle the attachment's file type and tells it to print the file.  Try this.  Set a physical printer to be the default printer.  Open Windows Explorer.  Find a PDF file, right-click it, and select Print.  Does the print job go to the physical printer or does it go to PDF Creator?

I can modify the code to print all the sheets in the spreadsheet.  Before we do that I'd like to get the printer issue put to bed.  I don't want to complicate troubleshooting it by adding code.
0

Expert Comment

by:apollo-13
Hi
I got error all time if i clik macro activ. Where i do fehler
macro
0

Expert Comment

by:paul0358
Hi bluedevilfan, thanks for the code! It works great! I was wondering if you knew of a way to modify the code to print all incoming email attachments to one PDF document. Also, is it possible to print to a windows fax server printer installed on a client computer? I've tried and an error message tells me that Fax printer doesn't exist...
0
LVL 76

Author Comment

by:David Lee
Hi, Paul.

Are you saying you want to print every message and all of the attachments to a single PDF file, or that you want each message and all its attachments to go to a single PDF?  Does the fax server printer appear as a printer?
0
LVL 76

Author Comment

by:David Lee
Hi, apollo-13.

The subroutine name cannot be the same as a module name.  Either move the code to Modeule1 and delete the MySubroutineName module, or change the name of the subroutine from MySubroutineName to some name of your choosing.
0

Expert Comment

by:paul0358
Hi bluedevilfan,

I would like to print all attachments to a single PDF file; I dont need to print the message at all really.

Yes, the fax printer appears in devices and printers. I've tried putting the printer name in the parameter as a string, and still it tell me that the printer does not exist. Here are the printer properties:
printer.png
0
LVL 1

Expert Comment

by:TPAMisfit
BDF, another question, please.

We disovered an issue where a bank sends several (sometimes fourteen or more) with the same attachment. We are using your code to move the e-mail to a subfolder and then print the "txt" attachments. Just formatted text about electronic transactions for the week. Anyway, when we receive many of these at the same time or within seconds of each other, the User is prompted as expected, but we see varying results on the activity. All the e-mail is moved to the respective folder and appears as "unread" but we get all kinds of print results: some print fine, some are completely skipped and others print in duplicate and/or triplicate. Wondering if there is a workaround for this, or if we need to somehow adjust the code you sent on 2011_03_28 to Ksquared. Any thoughts?

Thank you kindly.
0
LVL 1

Expert Comment

by:TPAMisfit
BDF...

Here is the code we are using to move the e-mail to a folder and print the attachments. It moves all the e-mail to the correct folder, shows all as "READ" but prints erratically, as noted above. Do you see anything that jumps out as to why it would skip some and then print duplicates of others?VBcode-test.txt
0
LVL 76

Author Comment

by:David Lee
paul0358,

I don't know of a solution for printing multiple items to one PDF.  I did some searching around and the only solutions I found talked about merging two PDF files.  If you know of some software that can print multiple items to a PDF, then we might be able to make that work with the script.  As is, I don't have an answer.

I tried setting the printer to my fax printer, the same as yours only on my computer not a remote computer, and everything worked.  I don't know what's going on there and I'm not in a position to test against a fax printer on another computer.
0
LVL 1

Expert Comment

by:TPAMisfit
Any ideas on the issue when multiple messages are received from the same Sender with the same "named" attachment where we get inconsistent printing results? Must be a way to regulate the process so as a message arrives, it is processed completely before continuing on another inbound message?
0
LVL 76

Author Comment

by:David Lee
TPAMisfit.

Outlook doesn't handle the printing.  The program registered to handle each particular file type takes care of that.  Programs don't typically provide a programming notification when a print completes, especially when they're being invoked indirectly.  To complicate matters more, you have to take into account that most programs spool print jobs.  Even if the program did provide notification that it had finished printing, that would only mean that the job had been sent to the spooler.  It doesn't mean that the job has actually been printed yet.  Depending on how busy the queue is for that printer, it could still be some time before the job actually prints.

While I haven't investigated doing this, there's probably some way to monitor the queue for a given printer and force processing to wait until a job completes before printing the next item.  That would have a huge negative impact on Outlook though.  It would sloe the program to a crawl as it waited for each item to complete printing before it printed the next item.

Another approach I could add is to implement a random delay.  For example, I could add a command that would force processing to wait x number of seconds before going on to the next item.  That too will have a negative effect on Outlook.
0

Expert Comment

by:Wallallen
I am using this wonderful macro in Outlook but I have a problem. I use Nuance PDF converter as my PDF reader and printer. For each PDF ( as many as 5) in the emails that I receive, it will open up a separate session for each document and I have to close each one separately. Can I make your program use a different PDF reader for printing and still use my nuance PDF converter as my main reader? Or can we make the Nuance work right?
0

Expert Comment

by:Wallallen
Also can we make the Nuance PDF converter and the image printer close after printing?
0
LVL 76

Author Comment

by:David Lee
Wallallen,

Do you know the name of the tasks for each of them?  If so, then I can add a command that will kill them.
0
LVL 76