Forum Discussion
Outlook 2016 - save multiple attachments at once to network drive - not possible
- Mar 01, 2018
This is an Outlook known issue. You can check them all in here.
More specifically, this is the one you are talking about: https://support.office.com/en-ie/article/unable-to-save-all-attachments-to-a-shared-network-drive-4e9d1fd2-3a4b-4a22-acd0-2ff1217edd8c?ui=en-US&rs=en-IE&ad=IE
So, still no fix from Microsoft.
Patrick, please share your solution. As the bug has been present for more than half a year it seem Microsoft has no intention of fixing this.
this is the vba code :
you can adjust the inbox map print in this source in whatever you want.
================================================
Option Explicit
Dim WithEvents TargetFolderItems As Items
Const FILE_PATH As String = "C:\Temp2\" 'you have to create this map on your c-drive
'Private Declare Function ShellExecute Lib "shell32.dll" Alias _
Private Declare PtrSafe 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
Private Sub Application_Startup()
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim olFolder As Outlook.MAPIFolder
Dim msg As Outlook.MailItem
Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
Set olFolder = objNS.GetDefaultFolder(olFolderInbox)
Set olFolder = olFolder.Folders("print") ' map inside the inbox
Set TargetFolderItems = olFolder.Items
End Sub
Sub TargetFolderItems_ItemAdd(ByVal Item As Object)
On Error Resume Next
Dim colAtts As Outlook.Attachments
Dim oAtt As Outlook.Attachment
Dim sFile As String
Dim sDirectory As String
Dim sFileType As String
Set colAtts = Item.Attachments
If colAtts.Count Then
For Each oAtt In colAtts
Dim pos As Long
pos = Len((oAtt.FileName)) - InStr(1, oAtt.FileName, ".", vbTextCompare) + 1
sFileType = LCase$(Right$(oAtt.FileName, pos))
Select Case sFileType
Case ".prt"
sFile = FILE_PATH & oAtt.FileName
sFile = Replace(sFile, " ", "") ' remove spaces from file
oAtt.SaveAsFile sFile & ".doc"
Case ".xlsx", ".docx", ".pdf", ".doc", ".xls"
sFile = FILE_PATH & oAtt.FileName
sFile = Replace(sFile, " ", "")
oAtt.SaveAsFile sFile
End Select
Next
End If
End Sub
Private Sub Application_Quit()
Dim ns As Outlook.NameSpace
Set TargetFolderItems = Nothing
Set ns = Nothing
End Sub
================ end vba code =============================
this is the vbs script, you have to place inside the temp2 directory, see vba code above for directory
============= start of vbs script ==============================
Dim objOffice, oWkbk, strFile
If WScript.Arguments.Count = 0 Then
' no arguments passed from command line
WScript.Quit
Else
strFile = Wscript.Arguments(0)
' Print XLS document
If (Right(strFile, 3) = "xls") Then
Set objOffice = CreateObject("Excel.Application")
objOffice.Visible = False
Set oWkbk = objOffice.Workbooks.Open(strFile)
oWkbk.PrintOut
oWkbk.Close xlDoNotSaveChanges
objOffice.Quit
End If
' Print XLS document
If (Right(strFile, 4) = "xlsx") Then
Set objOffice = CreateObject("Excel.Application")
objOffice.Visible = False
Set oWkbk = objOffice.Workbooks.Open(strFile)
oWkbk.PrintOut
oWkbk.Close xlDoNotSaveChanges
objOffice.Quit
End If
' Print WORD document
If (Right(strFile, 4) = "docx") Then
Set objOffice = WScript.CreateObject("Word.Application")
objOffice.Documents.Open strFile
objOffice.ActiveDocument.PrintOut
Wscript.Sleep(1000)
objOffice.ActiveDocument.Close
objOffice.Quit
End If
' Print WORD document
If (Right(strFile, 3) = "doc") Then
Set objOffice = WScript.CreateObject("Word.Application")
' objOffice.Documents.Open strFile
objOffice.Documents.Open strFile
objOffice.ActiveDocument.PrintOut
Wscript.Sleep(1000)
objOffice.ActiveDocument.Close
objOffice.Quit
End If
If (Right(strFile, 3) = "pdf") Then
Set sh = CreateObject("WScript.Shell")
sh.Run """Acrobat.exe"" /p /h"&strFile,,true
Wscript.Sleep(1000)
End If
End If
====== end of vbs script== put this file inside the temp2 dir ================
the 3d file is a vb net application i wrote, if needed send me a p.m. , or you can make a cmd file yourself for executing the vbs script file.
good luck
- Michael BarrJun 20, 2018Copper Contributor
Patrick,
Thank you for your attempt to help, but your code does not address the issue this thread is about. We're not trying to print arriving documents, we're trying to use an existing Outlook command for saving multiple attachments in a single message to a network location of our choosing. This is a function that has worked for years but was broken in build 1712 and is yet to be fixed.