Print Attachments

[Ruth]

Hello

I have found the following code on the net; it prints
selected attachments using the appropriate program.
However it does not close the Acrobat Reader after
printing the document, this causes the execution to stall
until Acrobat is closed manually. I have tried sending
keys etc to close the program but with no luck.
Anyone suggest an amendment that will achieve this.

Regards Ruth

Public Sub printAtt()
Dim objAttFld As MAPIFolder
Dim objInbox As MAPIFolder
Dim objNS As NameSpace
Dim strProgExt As String
Dim objAtt As Attachment
Dim intPos As Integer
Dim i As Integer
Dim strExt As String
Dim fso As Object
Dim tempFolder As Object, myTempFolder As Object
Dim tempName As String
Dim myOlExp As Outlook.Explorer
Dim myOlSel As Outlook.Selection


Dim olDocApp As Object
Dim olDoc As Object
Dim olXlsApp As Object
Dim olXls As Object
Dim olPptApp As Object
Dim olPpt As Object
Dim itm As Object
Dim wshShell As Object
Dim cmdLine As String
Dim strRun As String

Set myOlExp = Application.ActiveExplorer
Set myOlSel = myOlExp.Selection

On Error Resume Next
If myOlSel.Count > 0 Then
Set fso = Application.CreateObject
("Scripting.FileSystemObject")
If Err.Number <> 0 Then
Err.Clear
MsgBox "Need to have WSH installed on your
machine. Sorry.", vbOK, "Error"
Set fso = Nothing
Exit Sub
Else
Set tempFolder = fso.GetSpecialFolder
(2) 'TempFolder
tempName = tempFolder & "\" & fso.GetTempName
Set myTempFolder = fso.CreateFolder(tempName)
For Each itm In myOlSel
'itm.PrintOut '------------------ Uncomment if
you want to print the selected mail also
For Each objAtt In itm.Attachments
intPos = InStrRev(objAtt.FileName, ".")
strExt = LCase(Mid(objAtt.FileName, intPos +
1))
Select Case strExt
Case "doc"
objAtt.SaveAsFile myTempFolder & "\" &
objAtt.DisplayName
Set olDocApp = Application.CreateObject
("Word.Application")
Set olDoc = olDocApp.Documents.Open
(myTempFolder & "\" & objAtt.DisplayName)
olDoc.PrintOut
olDoc.Close 0
olDocApp.Quit
Set olDocApp = Nothing
Case "xls"
objAtt.SaveAsFile myTempFolder & "\" &
objAtt.DisplayName
Set olXlsApp = Application.CreateObject
("Excel.Application")
Set olXls = olXlsApp.Workbooks.Open
(myTempFolder & "\" & objAtt.DisplayName)
olXls.PrintOut
olXls.Close 0
Set olXls = Nothing
olXlsApp.Quit
Set olXlsApp = Nothing
Case "ppt"
objAtt.SaveAsFile myTempFolder & "\" &
objAtt.DisplayName
Set olPptApp = Application.CreateObject
("Powerpoint.Application")
Set olPpt = olPptApp.Presentations.Open
(myTempFolder & "\" & objAtt.DisplayName)
olPpt.PrintOut
olPpt.Close 0
Set olPpt = Nothing
olPptApp.Quit
Set olPptApp = Nothing

Case "pdf"
objAtt.SaveAsFile myTempFolder & "\" &
objAtt.DisplayName

Set wshShell = Application.CreateObject
("Wscript.Shell")
cmdLine = "AcroRd32 /p /h " &
myTempFolder & "\" & objAtt.DisplayName
strRun = wshShell.Run(cmdLine, 1, True)
wshShell.Quit
Set wshShell = Nothing

Case "txt"
objAtt.SaveAsFile myTempFolder & "\" &
objAtt.DisplayName

Set wshShell = Application.CreateObject
("Wscript.Shell")
cmdLine = "notepad.exe /p " &
myTempFolder & "\" & objAtt.DisplayName
strRun = wshShell.Run(cmdLine, 1, True)
wshShell.Quit
Set wshShell = Nothing
Case "tif"
MsgBox "found Tif"
MoveFaxItems
Case Else
End Select
Set objAtt = Nothing
Next

Next
Set itm = Nothing
Set tempFolder = Nothing
fso.DeleteFolder myTempFolder
Set fso = Nothing
End If
End If

End Sub