#1
|
|||
|
|||
How can I save all attachments in a folder with specific criteria?
Hello,
I was hoping someone could help me with my MS Office 2007. I redirect all of my artwork files from our studio to a specific sub-folder. I need to start saving all of the attachments into a networked folder, which is a pain because I get at least 50 emails each working day! My question is is there a way I can run a command that automatically saves the attachments in this sub folder, to a specific destination, where if the file already exists it is overwritten? What I will also like is to be able to run this routine and if the file already exists only overwrite if the file is newer this is because occasionally I will get amended PDF files throughout the year so I need only the latest one available. Can anyone help please? |
#2
|
||||
|
||||
The following will save the attachments in a named folder which it will create if not present (it may not work with a network folder that has not been mapped to a Windows drive letter.).
You can either process an individual message already received or run the main 'SaveAttachments' process from a rule as the messages arrive. The macro does not overwrite existing files of the same name (if you don't want that remove the line - Code:
strFname = FileNameUnique(strSaveFldr, strFname, strExt) Code:
Option Explicit Sub ProcessAttachment() 'An Outlook macro by Graham Mayor Dim olMsg As MailItem On Error Resume Next Set olMsg = ActiveExplorer.Selection.Item(1) SaveAttachments olMsg lbl_Exit: Exit Sub End Sub Private Sub SaveAttachments(olItem As MailItem) 'An Outlook macro by Graham Mayor Dim olAttach As Attachment Dim strFname As String Dim strExt As String Dim j As Long Const strSaveFldr As String = "D:\Path\Reports\" CreateFolders strSaveFldr On Error GoTo CleanUp If olItem.Attachments.Count > 0 Then For j = olItem.Attachments.Count To 1 Step -1 Set olAttach = olItem.Attachments(j) If Not olAttach.FileName Like "image*.*" Then strFname = olAttach.FileName strExt = Right(strFname, Len(strFname) - InStrRev(strFname, Chr(46))) strFname = FileNameUnique(strSaveFldr, strFname, strExt) olAttach.SaveAsFile strSaveFldr & strFname 'olAttach.Delete 'delete the attachment End If Next j olItem.Save End If CleanUp: Set olAttach = Nothing Set olItem = Nothing lbl_Exit: Exit Sub End Sub Private Function FileNameUnique(strPath As String, _ strFileName As String, _ strExtension As String) As String 'An Outlook macro by Graham Mayor Dim lngF As Long Dim lngName As Long lngF = 1 lngName = Len(strFileName) - (Len(strExtension) + 1) strFileName = Left(strFileName, lngName) Do While FileExists(strPath & strFileName & Chr(46) & strExtension) = True strFileName = Left(strFileName, lngName) & "(" & lngF & ")" lngF = lngF + 1 Loop FileNameUnique = strFileName & Chr(46) & strExtension lbl_Exit: Exit Function End Function Private Function FileExists(filespec) As Boolean 'An Outlook macro by Graham Mayor Dim fso As Object Set fso = CreateObject("Scripting.FileSystemObject") If fso.FileExists(filespec) Then FileExists = True Else FileExists = False End If lbl_Exit: Exit Function End Function 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
__________________
Graham Mayor - MS MVP (Word) (2002-2019) Visit my web site for more programming tips and ready made processes www.gmayor.com |
|
Similar Threads | ||||
Thread | Thread Starter | Forum | Replies | Last Post |
Outlook 2010: Saving attachments opens up wrong windows folder to save in | jeroen | Outlook | 0 | 09-29-2015 01:51 AM |
Excel VBA Macro - Deleting Specific Data based on criteria | MD011 | Excel Programming | 3 | 12-10-2014 02:15 AM |
Deleting rows with specific criteria | joflow21 | Excel | 9 | 11-22-2013 12:10 PM |
Print attachment when it arrive in specific folder with specific subject | visha_1984 | Outlook | 1 | 01-30-2013 10:42 AM |
Search Folder sent to criteria | markstro | Outlook | 0 | 12-20-2011 02:47 PM |