?
Solved

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

Posted on 2012-08-16
16
Medium Priority
?
1,279 Views
Last Modified: 2012-08-24
Hey there!

I have VERY limited knoledge of VBA but have come across your very useful site and have successfully installed a VBA code from BlueDevilFan which automatically prints attachments received into a certain email account (thank you BDF! Awesome work!)

I have clients emailing orders, which I need to automatically print, but some of the ordered emails come as a Outlook Item File, which then needs to be opened and then the PDF can be printed (all very frustrating)

Is it at all possible to include in BDF's code something that will identify the Outlook Item File, open this, then run the VBA code to automatically print the order? (hoping I am making sense!)

The code I have used from BDF is as follows....

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



Then

Sub PrintAttachment(Item As Outlook.MailItem)
        MessageAndAttachmentProcessor Item, , , True, True, , "PDF,XLS,XLSX,DOC,DOCX", "s:\RD1 Emailed Orders", , "BrotherFAXPRINTER"
End Sub

Open in new window


Is this possible?

Thanks heaps for all of your help!!
0
Comment
Question by:Rossco_milkbar
  • 7
  • 7
14 Comments
 
LVL 76

Expert Comment

by:David Lee
ID: 38309410
Hi, Rossco_milkbar.

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

Author Comment

by:Rossco_milkbar
ID: 38310026
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 !
0
 
LVL 76

Expert Comment

by:David Lee
ID: 38311125
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

Open in new window

0
Transaction-level recovery for Oracle database

Veeam Explore for Oracle delivers low RTOs and RPOs with agentless transaction log backup and transaction-level recovery of Oracle databases. You can restore the database to a precise point in time, even to a specific transaction.

 

Author Comment

by:Rossco_milkbar
ID: 38313857
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
1
 
LVL 76

Expert Comment

by:David Lee
ID: 38315590
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?
0
 

Author Comment

by:Rossco_milkbar
ID: 38318517
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?
0
 
LVL 76

Expert Comment

by:David Lee
ID: 38319914
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?
0
 

Author Comment

by:Rossco_milkbar
ID: 38322414
That would be fantastic if you could

thanks very much!!
0
 
LVL 76

Expert Comment

by:David Lee
ID: 38324122
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

Open in new window

0
 

Author Comment

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

Thank you
0
 

Author Comment

by:Rossco_milkbar
ID: 38328518
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
0
 
LVL 76

Expert Comment

by:David Lee
ID: 38328502
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.
0
 
LVL 76

Accepted Solution

by:
David Lee earned 2000 total points
ID: 38328519
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.
0
 

Author Closing Comment

by:Rossco_milkbar
ID: 38328610
just brilliant to work with

thank you
0

Featured Post

Industry Leaders: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

Question has a verified solution.

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

Microsoft Office Picture Manager was included in Office 2003, 2007, and 2010, but not in Office 2013. Users had hopes that it would be in Office 2016/Office 365, but it is not. Fortunately, the same zero-cost technique that works to install it with …
In a use case, a user needs to close an opened report by simply pressing the Escape (Esc) key. This can be done by adding macro code in Report_KeyPress or Report_KeyDown event.
A short tutorial showing how to set up an email signature in Outlook on the Web (previously known as OWA). For free email signatures designs, visit https://www.mail-signatures.com/articles/signature-templates/?sts=6651 If you want to manage em…
Have you created a query with information for a calendar? ... and then, abra-cadabra, the calendar is done?! I am going to show you how to make that happen. Visualize your data!  ... really see it To use the code to create a calendar from a q…

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

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

Join & Ask a Question