VBA Script error -

[barrye8]

Hi

I've had a look around the forums but can't find anything.

I found a script on the Internet that auto prints email attachments to your default printer as soon as they arrive. Seemed simple enough and it works. However, now every time I receive an email, regardless if it has an attachment, I get the error : 424 - Object required. The only option I have is to click OK to make the box disappear.

The guide said:

1. In Outlook, go to Developer tab and click "Visual Basic" button
   If you don't have "Developer" tab, go to customize your ribbon/toolbar and add "Developer"
2. In new window titled "Microsoft Visual Basic for Applications", double-click "ThisOutlookSession" icon in the tree on left side and paste the following script text into the new window on the right:
   
   Sub LSPrint(Item As Outlook.MailItem)
   On Error GoTo OError
   
   'detect Temp
   Dim oFS As FileSystemObject
   Dim sTempFolder As String
   Set oFS = New FileSystemObject
   'Temporary Folder Path
   sTempFolder = oFS.GetSpecialFolder(TemporaryFolder)
   
   'creates a special temp folder
   cTmpFld = sTempFolder & "\OETMP" & Format(Now, "yyyymmddhhmmss")
   MkDir (cTmpFld)
   
   'save & print
   Dim oAtt As Attachment
   For Each oAtt In Item.Attachments
   FileName = oAtt.FileName
   FullFile = cTmpFld & "\" & FileName
   
   'save attachment
   oAtt.SaveAsFile (FullFile)
   
   'prints attachment
   Set objShell = CreateObject("Shell.Application")
   Set objFolder = objShell.NameSpace(0)
   Set objFolderItem = objFolder.ParseName(FullFile)
   objFolderItem.InvokeVerbEx ("print")
   
   Next oAtt
   
   'Cleanup
   If Not oFS Is Nothing Then Set oFS = Nothing
   If Not objFolder Is Nothing Then Set objFolder = Nothing
   If Not objFolderItem Is Nothing Then Set objFolderItem = Nothing
   If Not objShell Is Nothing Then Set objShell = Nothing
   
   OError:
   If Err <> 0 Then
   MsgBox Err.Number & " - " & Err.Description
   Err.Clear
   End If
   Exit Sub
   
   End Sub
3. Go to menu Tools > References and add a reference to "Microsoft Scripting Runtime". Click OK button to close References window.
4. Hit Save icon on top toolbar and close Visual Basic window.
5. Create a rule in Outlook for all incoming messages from a certain person (or from who you receive those attachments) and choose run a script action.

I am hoping that someone who knows what they're doing could tell me what needs to be changed.

I'm using it on Outlook 2013 on Windows 8

I appreciate any help or advice.

Thanks

Barry

[gmayor]

Debugging other people's code is a pain, so perhaps it would be simpler to just post a version that should work. This one goes in an ordinary module and not ThisOutlookSession (remove the earlier version from that folder). It uses a couple of standard functions from my web site to create the temporary folder (if not already present). The code includes a test macro so that you can test whether it works for you without the need to use the rule. Select a message and run the test macro.

Option Explicit
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 TestMacro()
Dim olMsg As MailItem
    On Error Resume Next
    Set olMsg = ActiveExplorer.Selection.Item(1)
    LSPrint olMsg
lbl_Exit:
    Exit Sub
End Sub

Sub LSPrint(Item As Outlook.MailItem)
    On Error GoTo Err_Handler
    Dim oAtt As Attachment
    Dim FSO As Object
    Dim sTempFolder As Object
    Dim cTmpFld As String
    Dim strFilename As String
    Dim strFullFile As String

    Set FSO = CreateObject("scripting.filesystemobject")
    Set sTempFolder = FSO.GetSpecialFolder(2)

    'creates a special temp folder
    cTmpFld = sTempFolder & "\OETMP" & Format(Now, "yyyymmddhhmmss")
    CreateFolders cTmpFld

    'save & print
    For Each oAtt In Item.Attachments
        If Not oAtt.FileName Like "image*.*" Then 'Omit images in the message
            strFilename = oAtt.FileName
            strFullFile = cTmpFld & "\" & strFilename
            'save attachment
            oAtt.SaveAsFile strFullFile
            'print attachment
            ShellExecute 0, "print", strFullFile, vbNullString, vbNullString, 0
        End If
    Next oAtt

    'Cleanup
    If Not FSO Is Nothing Then Set FSO = Nothing
lbl_Exit:
    Exit Sub

Err_Handler:
    If Err <> 0 Then
        MsgBox Err.Number & " - " & Err.Description
        Err.Clear
    End If
    GoTo lbl_Exit
End Sub

Private Function FolderExists(fldr) As Boolean
'An Outlook macro by Graham Mayor
Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    If (FSO.FolderExists(fldr)) Then
        FolderExists = True
    Else
        FolderExists = False
    End If
lbl_Exit:
    Exit Function
End Function

Private Function CreateFolders(strPath As String)
'An Outlook macro by Graham Mayor
Dim strTempPath As String
Dim lngPath As Long
Dim vPath As Variant
    vPath = Split(strPath, "\")
    strPath = vPath(0) & "\"
    For lngPath = 1 To UBound(vPath)
        strPath = strPath & vPath(lngPath) & "\"
        If Not FolderExists(strPath) Then MkDir strPath
    Next lngPath
lbl_Exit:
    Exit Function
End Function

[barrye8]

Wow, such a quick and through response. I appreciate your time Graham.

Script seems to work perfectly. No errors at all.

Thanks again. (I sent £5 your way via your website as a more tangible thanks )

[gmayor]

I wondered who that was from - thanks

[barrye8]

No problem

This has worked very well but has caused a new issue which I didn't consider. It prints attachments as the email arrives but I work in an office with 30 other people and they keep taking the print out with their own paper work and either just bin it or don't even know they have it. I'm often away from my desk so this is becoming quite an issue.

Any ideas how to set-up a button to print the attachments on unread message in a certain mailbox.

[gmayor]

Instead of running the main macro from a rule, run it from a macro that will detect the unread messages in a folder and print those. Essentially it would be a variation on the test macro e.g.

Sub PrintUnreadMessages()
Dim olNS As Outlook.NameSpace
Dim olFolder As Outlook.Folder
Dim olItem As Outlook.MailItem
    On Error GoTo Err_Handler
    Set olNS = GetNamespace("MAPI")
    Set olFolder = olNS.PickFolder
    For Each olItem In olFolder.Items
        If olItem.UnRead Then
            LSPrint olItem
        End If
    Next olItem
lbl_Exit:
    Set olNS = Nothing
    Set olFolder = Nothing
    Set olItem = Nothing
    Exit Sub
Err_Handler:
    GoTo lbl_Exit
End Sub