Automatically save att. in outlook 2007

[ingridgoss]

Hi,

I have absolutely no knowledge about VB, I normally work in mainframe environment.
However, I found a script a few years ago on this forum which made it possible to automatically save mail attachments to a specific location. Combined with a rule in outlook, this worked perfectly until... we moved to outlook 2007. Now it doesn't seem to do anything anymore, either because I missed something in setting up the script again, or there are differences between VB in office 2003 and 2007 ?

Here's what I now have in "ThisOutlookSession", hope someone can help :

Dim WithEvents TargetFolderItems As Items
'set the string constant for the path to save attachments
Const FILE_PATH As String = "G:\ELSO ORDERS\"

' this is the Application_Startup event code in the ThisOutlookSession module
Private Sub Application_Startup()
'some startup code to set our "event-sensitive" items collection
Dim ns As Outlook.NameSpace
'
Set ns = Application.GetNamespace("MAPI")
Set TargetFolderItems = ns.GetDefaultFolder(olFolderInbox).Folders.Item("ELSO WO").Items

End Sub

' this is the Application_Quit event code in the ThisOutlookSession module
Private Sub Application_Quit()

Dim ns As Outlook.NameSpace
Set TargetFolderItems = Nothing
Set ns = Nothing

End Sub

Public Sub RuleScriptSaveAtt(Item As MailItem)

Dim olAtt As Attachment
Dim i As Integer

If Item.Attachments.Count > 0 Then
For i = 1 To Item.Attachments.Count
Set olAtt = Item.Attachments(i)
olAtt.SaveAsFile FILE_PATH & olAtt.FileName
Next
End If
Set olAtt = Nothing

End Sub

[JP2112]

I don't see anything that would cause this code to fail, but I don't have Outlook 2007 to test it. I would try

1. fully qualifying all my variables (i.e. change As Items to As Outlook.Items)
2. removing the Application_Quit procedure (it's useless)
3. completely recreating the rule

Make sure the code hasn't been moved since the rule was created.

I would also set Outlook macro security settings to Medium, make sure the VB Project is digitally signed, and restart Outlook.

[ingridgoss]

Hi JP,

thanks for the swift reply. Will do as you suggest, now I know the code is OK, I can look further.

regards,
INgrid

[Lorentb]

Hello, I got some code like this and I got it working as long as the outlook account is active. How can I have this code work even when the account is not active?

Thanks for the help!!

[monarchd]

Made some tweaks to Killian's awesome code to allow for multiple file types as extensions. Don't really have much debugging in it so don't yell at me. I'm a novice in VBA and just now going to go back and try to add some of that in. Right now you'll see the hideous On Error Resume Next.

That said, I've had the code below running for over a year, every day and the only time it gives me trouble is when either an OLE object is in the message or there is an unidentified attachment.

I also added in some "timing" to get the main message body then the attachment to print as synchroneous as possible. The mailbox this is running on it really busy with 5-10 messages arriving in a minute span.

I've tried to give/keep the credit lines in the code, but if I missed a credit, just let me know as it wasn't intentional.

Enjoy:




Option Explicit
Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, _
ByVal bInheritHandle As Long, _
ByVal dwProcessId As Long) As Long
Declare Function GetExitCodeProcess Lib "kernel32" (ByVal hProcess As Long, _
lpExitCode As Long) As Long
Public Const PROCESS_QUERY_INFORMATION = &H400
Public Const STILL_ACTIVE = &H103
'********************************************
'* MACRO TWEAKS (c) 2010 N. Fusco *
'********************************************
'globally define the path to save the attachments
Const FILE_PATH As String = "C:\Temp\"
'********************************************
'* FUNCTION (c) 1999-2000 Sergey Merzlikin *
'********************************************
Private Const STATUS_TIMEOUT = &H102&
Private Const INFINITE = -1& ' Infinite interval
Private Const QS_KEY = &H1&
Private Const QS_MOUSEMOVE = &H2&
Private Const QS_MOUSEBUTTON = &H4&
Private Const QS_POSTMESSAGE = &H8&
Private Const QS_TIMER = &H10&
Private Const QS_PAINT = &H20&
Private Const QS_SENDMESSAGE = &H40&
Private Const QS_HOTKEY = &H80&
Private Const QS_ALLINPUT = (QS_SENDMESSAGE Or QS_PAINT _
Or QS_TIMER Or QS_POSTMESSAGE Or QS_MOUSEBUTTON _
Or QS_MOUSEMOVE Or QS_HOTKEY Or QS_KEY)
Private Declare Function MsgWaitForMultipleObjects Lib "user32" (ByVal nCount As Long, pHandles As Long, ByVal fWaitAll As Long, ByVal dwMilliseconds As Long, ByVal dwWakeMask As Long) As Long
Private Declare Function GetTickCount Lib "kernel32" () As Long
' The MsgWaitObj function replaces Sleep, WaitForSingleObject, WaitForMultipleObjects functions.
' Unlike these functions, it doesn't block thread messages processing.
' Using instead Sleep:
' MsgWaitObj dwMilliseconds
' Using instead WaitForSingleObject:
' retval = MsgWaitObj(dwMilliseconds, hObj, 1&)
' Using instead WaitForMultipleObjects:
' retval = MsgWaitObj(dwMilliseconds, hObj(0&), n),
' where n - wait objects quantity,
' hObj() - their handles array.
Public Function MsgWaitObj(Interval As Long, Optional hObj As Long = 0&, Optional nObj As Long = 0&) As Long
Dim T As Long, T1 As Long
If Interval <> INFINITE Then
T = GetTickCount()
On Error Resume Next
T = T + Interval
' Overflow prevention
If Err <> 0& Then
If T > 0& Then
T = ((T + &H80000000) + Interval) + &H80000000
Else
T = ((T - &H80000000) + Interval) - &H80000000
End If
End If
On Error GoTo 0
' T contains now absolute time of the end of interval
Else
T1 = INFINITE
End If
Do
If Interval <> INFINITE Then
T1 = GetTickCount()
On Error Resume Next
T1 = T - T1
' Overflow prevention
If Err <> 0& Then
If T > 0& Then
T1 = ((T + &H80000000) - (T1 - &H80000000))
Else
T1 = ((T - &H80000000) - (T1 + &H80000000))
End If
End If
On Error GoTo 0
' T1 contains now the remaining interval part
If IIf((T1 Xor Interval) > 0&, T1 > Interval, T1 < 0&) Then
' Interval expired
' during DoEvents
MsgWaitObj = STATUS_TIMEOUT
Exit Function
End If
End If
' Wait for event, interval expiration
' or message appearance in thread queue
MsgWaitObj = MsgWaitForMultipleObjects(nObj, hObj, 0&, T1, QS_ALLINPUT)
' Let's message be processed
DoEvents
If MsgWaitObj <> nObj Then Exit Function
' It was message - continue to wait
Loop
End Function
'**********************************************************
'* SAVE ATTACHEMENTS BY KILLIAN AT VBAEXPRESS *************
'**********************************************************
Sub PrintAtt(fFullPath As String)
Dim xlApp As Excel.Application
Dim wb As Excel.Workbook
'in the background, create an instance of excel then open, print, quit
Set xlApp = New Excel.Application
Set wb = xlApp.Workbooks.Open(fFullPath)
wb.PrintOut
xlApp.Quit
'play nice
Set wb = Nothing
Set xlApp = Nothing
End Sub
Public Sub RuleScriptSaveAtt(Item As MailItem)
Dim olAtt As Attachment
Dim i As Integer
'this script is run from a clientside rule in Outlook
If Item.Attachments.Count < 1 Then
MsgWaitObj 1000
Item.PrintOut
Exit Sub
End If
If Item.Attachments.Count >= 1 Then
For i = 1 To Item.Attachments.Count
Set olAtt = Item.Attachments(i)
On Error Resume Next
olAtt.SaveAsFile FILE_PATH & olAtt.FileName
'with the attached file, pass the filepath to the correct print routine
'make sure the paths to shell are exactly right, may have to be configured per pc
'wait for it
MsgWaitObj 2000

On Error Resume Next
'excel files, using excel
If UCase(Right(olAtt.FileName, 3)) = "XLS" Then
MsgWaitObj 3000
Item.PrintOut
PrintAtt (FILE_PATH & olAtt.FileName)
End If
'pdf files, using adobe reader
If UCase(Right(olAtt.FileName, 3)) = "PDF" Then
MsgWaitObj 2000
Item.PrintOut
Shell """C:\Program Files\Adobe\Reader 9.0\Reader\AcroRd32.exe"" /h /p """ + FILE_PATH & olAtt.FileName + """", vbHide
End If
'tif files, using mspaint
If UCase(Right(olAtt.FileName, 3)) = "TIF" Then
MsgWaitObj 2000
Item.PrintOut
Shell """C:\windows\System32\mspaint.exe"" /p """ + FILE_PATH & olAtt.FileName + """", vbHide
End If

'jpg files, using mspaint
If UCase(Right(olAtt.FileName, 3)) = "JPG" Then
MsgWaitObj 2000
Shell """C:\windows\System32\mspaint.exe"" /p """ + FILE_PATH & olAtt.FileName + """", vbHide
End If

'gif files, using mspaint
If UCase(Right(olAtt.FileName, 3)) = "GIF" Then
MsgWaitObj 2000
Shell """C:\windows\System32\mspaint.exe"" /p """ + FILE_PATH & olAtt.FileName + """", vbHide
End If
'rtf files, using winword
If UCase(Right(olAtt.FileName, 3)) = "RTF" Then
MsgWaitObj 2000
Item.PrintOut
Shell """C:\windows\System32\write.exe"" /p """ + FILE_PATH & olAtt.FileName + """", vbHide
End If
'word files, this one calls an internal word macro for opening in word, printing and then closing
If UCase(Right(olAtt.FileName, 3)) = "DOC" Then
MsgWaitObj 2000
Item.PrintOut
Shell """C:\Program Files\Microsoft Office\Office12\Winword.exe"" /q /n /mFilePrintDefault """ + FILE_PATH & olAtt.FileName + """", vbHide
End If
'word 2007 files, this one calls an internal word macro for opening in word, printing and then closing
If UCase(Right(olAtt.FileName, 4)) = "DOCX" Then
MsgWaitObj 2000
Item.PrintOut
Shell """C:\Program Files\Microsoft Office\Office12\Winword.exe"" /q /n /mFilePrintDefault """ + FILE_PATH & olAtt.FileName + """", vbHide
End If

If UCase(Right(olAtt.FileName, 3)) = "ZIP" Then
MsgWaitObj 2000
Item.PrintOut
Shell """C:\Program Files\Winzip\Winzip.exe"" /q /n /mFilePrintDefault """ + FILE_PATH & olAtt.FileName + """", vbHide
MsgWaitObj 1000
Call B_UnZip_Zip_File_Fixed
End If
Next
End If
'play nice
Set olAtt = Nothing
End Sub
Public Sub ShellAndWait(ByVal PathName As String, Optional WindowState)
Dim hProg As Long
Dim hProcess As Long, ExitCode As Long
'fill in the missing parameter and execute the program
If IsMissing(WindowState) Then WindowState = 1
hProg = Shell(PathName, WindowState)
'hProg is a "process ID under Win32. To get the process handle:
hProcess = OpenProcess(PROCESS_QUERY_INFORMATION, False, hProg)
Do
'populate Exitcode variable
GetExitCodeProcess hProcess, ExitCode
DoEvents
Loop While ExitCode = STILL_ACTIVE
End Sub
'*****************************************************************
'* UNZIP CODE by Ron de Bruin *
'*****************************************************************
'With this example you can browse to the zip file you want to unzip
'The zip file will be unzipped in a new folder in: Application.DefaultFilePath
'Normal if you have not change it this will be your Documents folder
'The name of the folder that the code create in this folder is the Date/Time
'You can also use a fixed path like :
'NameUnZipFolder = "C:\Users\Ron\TestFolder\" & Format(Now, "yyyy-mm-dd hh-mm-ss")
'Read the comments in the code about the commands/Switches in the ShellStr
'There is no need to change the code before you test it
Sub A_UnZip_Zip_File_Browse()
Dim PathZipProgram As String, NameUnZipFolder As String
Dim FileNameZip As Variant, ShellStr As String
Dim Password As String
'Path of the Zip program
PathZipProgram = "C:\program files\winzip"
If Right(PathZipProgram, 1) <> "\" Then
PathZipProgram = PathZipProgram & "\"
End If
'Check if this is the path where WinZip is installed.
If Dir(PathZipProgram & "winzip32.exe") = "" Then
MsgBox "Please find your copy of winzip32.exe and try again"
Exit Sub
End If
'Create path and name of the normal folder to unzip the files in
'In this example we use: Application.DefaultFilePath
'Normal if you have not change it this will be your Documents folder
'The name of the folder that the code create in this folder is the Date/Time
NameUnZipFolder = Application.DefaultFilePath & "\" & Format(Now, "yyyy-mm-dd hh-mm-ss")
'You can also use a fixed path like :
'NameUnZipFolder = "C:\Users\Ron\TestFolder\" & Format(Now, "yyyy-mm-dd hh-mm-ss")
'Select the zip file (.zip or .zipx files)
FileNameZip = Application.GetOpenFilename(filefilter:="Zip Files, *.zip*", _
MultiSelect:=False, Title:="Select the file that you want to unzip")
'Unzip the files/folders from the zip file in the NameUnZipFolder folder
If FileNameZip = False Then
'do nothing
Else
'There are a few commands/Switches that you can change in the ShellStr
'If you add -j it will not keep the folder stucture, add it if you only want the files
'Use -o if you want to Overwrite existing files without prompting
ShellStr = PathZipProgram & "Winzip32 -min -e" _
& " " & Chr(34) & FileNameZip & Chr(34) _
& " " & Chr(34) & NameUnZipFolder & Chr(34)
'Add -s like this -sYourPassWordHere if you want to unzip a file with a password for the files in it
' Password = """topsecret""" 'Do not remove the six quotes
' ShellStr = PathZipProgram & "Winzip32 -min -e -s" & Password _
' & " " & Chr(34) & FileNameZip & Chr(34) _
' & " " & Chr(34) & NameUnZipFolder & Chr(34)
ShellAndWait ShellStr, vbHide
MsgBox "Look in " & NameUnZipFolder & " for extracted files"
End If
End Sub
'*****************************************************************
'* UNZIP CODE by Ron de Bruin *
'*****************************************************************
'With this example you unzip a fixed zip file: FileNameZip = "C:\Users\Ron\Test.zip"
'Note this file must exist, this is the only thing that you must change before you test it
'The zip file will be unzipped in a new folder in: Application.DefaultFilePath
'Normal if you have not change it this will be your Documents folder
'The name of the folder that the code create in this folder is the Date/Time
'You can also use a fixed path like :
'NameUnZipFolder = "C:\Users\Ron\TestFolder\" & Format(Now, "yyyy-mm-dd hh-mm-ss")
'Read the comments in the code about the commands/Switches in the ShellStr
Sub B_UnZip_Zip_File_Fixed()
Dim PathZipProgram As String, NameUnZipFolder As String
Dim FileNameZip As Variant, ShellStr As String
Dim Password As String
'Path of the Zip program
PathZipProgram = "C:\program files\winzip"
If Right(PathZipProgram, 1) <> "\" Then
PathZipProgram = PathZipProgram & "\"
End If

'Check if this is the path where WinZip is installed.
If Dir(PathZipProgram & "winzip32.exe") = "" Then
MsgBox "Please find your copy of winzip32.exe and try again"
Exit Sub
End If
'Create path and name of the normal folder to unzip the files in
'In this example we use: Application.DefaultFilePath
'Normal if you have not change it this will be your Documents folder
'The name of the folder that the code create in this folder is the Date/Time
'NameUnZipFolder = Application.DefaultFilePath & "\" & Format(Now, "yyyy-mm-dd hh-mm-ss")
'You can also use a fixed path like :
NameUnZipFolder = "C:\Temp\" & Format(Now, "yyyy-mm-dd hh-mm-ss")
'Name of the zip file that you want to unzip
FileNameZip = "C:\Temp\extract" & Format(Now, "yyyy-mm-dd hh-mm-ss") & ".zip"

'There are a few commands/Switches that you can change in the ShellStr
'If you add -j it will not keep the folder stucture, add it if you only want the files
'Use -o if you want to Overwrite existing files without prompting
'ShellStr = PathZipProgram & "Winzip32.exe -min -e" _
'& " " & Chr(34) & FileNameZip & Chr(34) _
'& " " & Chr(34) & NameUnZipFolder & Chr(34)
'Add -s like this -sYourPassWordHere if you want to unzip a file with a password for the files in it
Password = """whateverthepasswordis""" 'Do not remove the six quotes
ShellStr = PathZipProgram & "Winzip32 -min -e -s" & Password _
& " " & Chr(34) & FileNameZip & Chr(34) _
& " " & Chr(34) & NameUnZipFolder & Chr(34)

ShellAndWait ShellStr, vbHide
'MsgBox "Look in " & NameUnZipFolder & " for extracted files"
End Sub

[monarchd]

Also, I had to add in additional References. From Outlook, press Alt-F11 to bring up the code window. (My code in in a module here). Go to Tools | References and these are the one's I have set:

Visual Basic for Applications
Microsoft Outlook 12.0 Object Library
OLE Automation
Microsoft Office 12.0 Object Library
Microsoft Excel 12.0 Object Library
Acrobat Access 3.0 Type Library
Microsoft Word 12.0 Object Library