VBA to open Outlook Item File prior to running VBA script through Macro

Hi, Rossco_milkbar.

Why do the items need to be opened before they are printed?

Hi there BDF

First of all - thank you very much for your original script - I have very limited knowledge of VBA code and your solution resolves so many issues for us - THANK YOU.

Our customers emailed orders are normally sent with a PDF attachment and your script provided previously works perfectly. BUT on occasion our customers send the order attachment within another attachment (initially a Microsoft Item file) which when opened brings up the email with order attachment (I hope this makes sense!). I have attached a screen dump of what I mean for your reference.

Attachment.docx


I guess what I would like to know is, is it possible for the script to view the email and see if it is a Microsoft Item File, and if yes, then to open the attachment (Microsoft Item File) and then for the script to run as per normal, and if not run the script as normal.

Also is there any additional way to add to the script a condition which shows if the script has run successfully, for example move the email to a folder on the successful completion of the script - and if not it remains in the inbox (unprinted). What I have noticed is if i simply include this moving to a folder as part of the rule that contains the script, the email is moved regardless if the script ran successfully?

And Lastly (sorry) I would also like to know if your opinion accessing the PC via a VPN would affect the running of the rule? What I have noticed is the rule only works if run manually if I am connected via a VPN connection?

Sorry for all of the questions !

Thanks and you're welcome.  Glad you found the code useful.

I've modified the code to do what you described.  If the code discovers that an attachment is a message, then it will open that message and process its attachments.  Please test this solution before you put it into production.

From a programming perspective there really is no way to know if the script ran successfully or not.  For example, printing could fail and the code wouldn't have any way of knowing that since printing is handled by an external process.  I could add code that would move an item once it's been processed, but it's easier to let the rule do that.

In answer to the VPN question, no, a VPN won't make any difference.  

Replace the code you have now with the version below.

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, _
        olkAttachment1 As Outlook.Attachment, _
        olkTemp As Outlook.MailItem, _
        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, _
        intIndex1 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") & "\\Server\SharedDocs\rd1 emailed orders\"
        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 Not IsHiddenAttachment(olkAttachment) Then
                If LCase(objFSO.GetExtensionName(olkAttachment.FileName)) = "msg" Then
                    olkAttachment.SaveAsFile strTempFolder & olkAttachment.FileName
                    Set olkTemp = Application.CreateItemFromTemplate(strTempFolder & olkAttachment.FileName)
                    For intIndex1 = olkTemp.Attachments.Count To 1 Step -1
                        Set olkAttachment1 = olkTemp.Attachments.Item(intIndex1)
                        If Not IsHiddenAttachment(olkAttachment1) Then
                            For Each strFileType In arrFileTypes
                                If (strFileType = "*") Or (LCase(objFSO.GetExtensionName(olkAttachment1.FileName)) = LCase(strFileType)) Then
                                    olkAttachment1.SaveAsFile strTempFolder & olkAttachment1.FileName
                                    ShellExecute 0&, "print", strTempFolder & olkAttachment1.FileName, 0&, 0&, 0&
                                End If
                            Next
                        End If
                    Next
                End If
                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
                                  
Public 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

Select allOpen in new window

Thank you BDF - the new code works perfectly...

The only issue I need to try and figure out is why the rule runs sometimes, and sometimes not. When run manually the code works perfectly.

I have tried to changed the srs file to a old file and I have also run a check on the pst file - but there doesn't seem to be a solution I can figure out.

Are you aware of any resolution that will automate the rule?

I have attached a copy of the rule for your consideration

Cheers!
Automatic-rule.docx

Cool.

Do you have many rules or just a few?  Do you tend to get large batches of messages all at once or do they tend to comes in ones and twos?

Hi there again (sorry for all of the messages)

I have very few rules (two others on separate accounts).

What I have observed is the script runs perfectly with the email message has a normal attachment like a PDF, but when the script hits the Microsoft Item File (message attachment?) it needs to be run manually? (cant figure out why??)

Thoughts?

I don't know why the one type of message is causing a problem.  I can show you how to replace the rule by emulating it in code.  Do you want to try that?

That would be fantastic if you could

thanks very much!!

This should do it.  Place this code in the ThisOutlookSession module.  Now, disable the rule.  The code fires each time an item is received.  It checks to see if the item is a message and, if it is, if it came in through the account you specified in your rule.  If both are true, then it calls PrintAttachment and passes it the item.

Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
    Dim arrEID As Variant, varEID As Variant, olkItm As Object
    arrEID = Split(EntryIDCollection)
    For Each varEID In arrEID
        Set olkItm = Session.GetItemFromID(varEID)
        If olkItm.Class = olMail Then
            If LCase(olkItm.SendUsingAccount.SmtpAddress) = "orders@milkbar.co.nz" Then
                PrintAttachment olkItm
            End If
        End If
    Next
    Set olkItm = Nothing
End Sub

Select allOpen in new window

You are an absolute legend - thank you so much for all of your help ! it appears to be working perfectly!

Thank you

I've requested that this question be closed as follows:

Accepted answer: 0 points for Rossco_milkbar's comment #a38328134

for the following reason:

Just amazing, quick support - Thank you

I'm cancelling the close because Rossco_milkbar selected one of his comments instead of one of the solutions.  

Rossco_milkbar, if you're happy with the solutions, then please choose one of my posts so I get credit for the answer.

just brilliant to work with

thank you