Advertisement
Advertisement
| 08.25.2008 at 08:46AM PDT, ID: 23675572 |
|
[x]
Attachment Details
|
||
|
[x]
The Solution Rating System
|
||
With so many solutions, how can you tell which solutions are most likely to help you and which ones are not? To provide you with a tool to use, we rate our solutions based on various elements that most accurately determine if a solution is a quality solution. To explain what factors affect the solution rating, here are the elements we take into consideration when formulating our solution rating.
Your Input Matters If you have any suggestions that you would like to make for our rating system, please ask a question in the Suggestions Zone of Community Support. Thank you! |
||
1: 2: 3: 4: 5: 6: 7: 8: 9: 10: 11: 12: 13: 14: 15: 16: 17: 18: 19: 20: 21: 22: 23: 24: 25: 26: 27: 28: 29: 30: 31: 32: 33: 34: 35: 36: 37: 38: 39: 40: 41: 42: 43: 44: 45: 46: 47: 48: 49: 50: 51: 52: 53: 54: 55: 56: 57: 58: 59: 60: 61: 62: 63: 64: 65: 66: 67: 68: 69: 70: 71: 72: 73: 74: 75: 76: 77: 78: 79: 80: 81: 82: 83: 84: 85: 86: 87: 88: 89: 90: 91: 92: |
Stefri
'<<<<< snip >>>>>
Option Explicit
Dim objNS As NameSpace
Private WithEvents olInboxItems As Items
Private Sub Application_Startup()
Set objNS = Application.GetNamespace("MAPI")
Set olInboxItems = objNS.GetDefaultFolder(olFolderInbox).Items
End Sub
Private Sub Application_Quit()
Set olInboxItems = Nothing
Set objNS = Nothing
End Sub
Private Sub olInboxItems_ItemAdd(ByVal Item As Object)
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 olDocApp As Object
Dim olDoc As Object
Dim olXlsApp As Object
Dim olXls As Object
Dim olPptApp As Object
Dim olPpt As Object
On Error Resume Next
If Item.Class = olMail Then
Set fso = Application.CreateObject("Scripting.FileSystemObject")
If Err.Number <> 0 Then
Err.Clear
MsgBox "Need to have WSH installed on your machine. Sorry, cannot zip", vbOK, "Error: cannot zip"
Set fso = Nothing
Exit Sub
Else
Set tempFolder = fso.GetSpecialFolder(2) 'TempFolder
tempName = tempFolder & "\" & fso.GetTempName
Set myTempFolder = fso.CreateFolder(tempName)
For Each objAtt In Item.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 Else
End Select
Set objAtt = Nothing
Next
Set tempFolder = Nothing
fso.deleteFolder myTempFolder
Set fso = Nothing
End If
End If
End Sub
|