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:



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"
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
Go to menu Tools > References and add a reference to "Microsoft Scripting Runtime". Click OK button to close References window.
Hit Save icon on top toolbar and close Visual Basic window.
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