Outlook script to save a copy of the attachment (with specific criteria) in a specified folder

Give this a try.

 Dim objFSO As Object

Sub SaveAttachmentsBySubjectDateCurrent(NewEmail As MailItem)
    Dim NewAttachments As Outlook.Attachments
    Dim NewAttachment As Outlook.Attachment
    Dim SaveFolder As String
    Dim SavePath As String
   
    Dim BaseFolder As String
        
    ' Base folder for all attachments
    BaseFolder = "D:\Files"
    
    ' Get attachements to this email
    Set NewAttachments = NewEmail.Attachments
    
    ' If no attachments then we're done
    If NewAttachments.Count = 0 Then
        Set NewAttachments = Nothing
        Exit Sub
    End If
    
    ' Create folder if it doesn't exist
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    If Not objFSO.FolderExists(BaseFolder) Then
        MakeDir BaseFolder
    End If
    
    ' Process all attachments
    For Each NewAttachment In NewAttachments

        ' Only save certain file names...
        If InStr(1, NewAttachment.Filename, "AB202P3", vbTextCompare) > 0 And LCase(Right(NewAttachment.Filename, 5)) = ".xlsx" Then

            ' Add attachement file name to folder to get full path to save to
            SavePath = BaseFolder & "\" & NewFileName(NewAttachment.Filename)
            
            ' Only save if it doesn't already exist
            If Not objFSO.FileExists(SavePath) Then
                NewAttachment.SaveAsFile SavePath
            End If

        End If
    
    Next NewAttachment
    
    ' Clean up objects
    Set objFSO = Nothing
    Set NewAttachments = Nothing

End Sub

Sub MakeDir(strPath As String)
' Subroutine to create a folder as well as any needed parent folders

   Dim strAbsPath As String
   Dim strParent As String

   ' Get absolute path to folder to create
   strAbsPath = objFSO.GetAbsolutePathName(strPath)

   ' If it exists already we are done
   If objFSO.FolderExists(strAbsPath) Then
      Exit Sub
   End If

   ' Get the path for the parent of this folder
   strParent = objFSO.GetParentFolderName(strAbsPath)

   ' Stop when we get to the root
   If strParent <> "" Then
      ' If this parent folder doesn't exist create it (recursive to create any additional parents needed)
      If Not objFSO.FolderExists(strParent) Then
         MakeDir strParent
      End If
   End If

   ' Now create this folder
   objFSO.CreateFolder (strAbsPath)

End Sub

Function NewFileName(strOldFileName)
    ' existing name + "_21-10-11" (current day-1) => attachmentfile1_21-10-11.pdf where it is in YY-MM-DD format.
    NewFileName = objFSO.GetBaseName(strOldFileName) & "_" & TimeStamp(Now) & "." & objFSO.GetExtensionName(strOldFileName)

End Function

Function TimeStamp(ByVal dtmDateTime)
    ' YY-MM-DD format (current date)
    TimeStamp = Right(Year(dtmDateTime), 2) & "-" & Right("0" & Month(dtmDateTime), 2) & "-" & Right("0" & Day(dtmDateTime), 2)
End Function

Select allOpen in new window

---

»bp

What if I have multiple files - containing
1. "AB202P3"  
2. "AB202P1"
3. "AB203AR"

How do i add into the code:

 ' Only save certain file names...
        If InStr(1, NewAttachment.Filename, "AB202P3", vbTextCompare) > 0 And LCase(Right(NewAttachment.Filename, 5)) = ".xlsx" Then

Select allOpen in new window

        ' Only save certain file names...
        If (InStr(1, NewAttachment.FileName, "AB202P3", vbTextCompare) > 0 Or _
            InStr(1, NewAttachment.FileName, "AB202P1", vbTextCompare) > 0 Or _
            InStr(1, NewAttachment.FileName, "AB203AR", vbTextCompare) > 0) And _
            LCase(Right(NewAttachment.FileName, 5)) = ".xlsx" Then

Select allOpen in new window

---

»bp

I encounter the error when trying just 1 file:


What could have gone wrong? the script name and module name is the same. 

A bit odd, sounds like it can't see your macros, check for any changes to Outlook related to security, etc.

I've seen problems like this come and go from my Outlook install, but never got to root causes.  Outlook doesn't always work perfect...

If you create a new rule do you have the same problem?

If you go into the VBA editor do you still see the macro involved there?

---

»bp

If you create a new rule do you have the same problem? If you create a new rule do you have the same problem?
= This is the new rule.

It seems that the previous rule run ok, when with new rule it has this error.

If you go into the VBA editor do you still see the macro involved there?If you go into the VBA editor do you still see the macro involved there?
= Yes

When i tried to run

I also encounter the same error

And the new VBS macro you are trying to use still has a single parameter, of type MailItem, like:

Sub SaveAttachmentsBySubjectDateCurrent(NewEmail As MailItem)

Select allOpen in new window

---

»bp

Yes all single parameter.

Not sure what happened on your system.  I would suggest just working through everything again, creating a new rule, etc.  Checking macro and security related settings to make sure macros aren't being blocked.  Apply any Windows and Office updates.  Somewhat of a stretch, but you could do a repair of the Office install as well.  And a reboot or two along the way...

---

»bp

The strange thing is the old rule is ok but the new rule (as in new creation) has this issue.

For the new rule, you are trying to use a new Sub() that you created for it?

And that Sub() is in the same module where the working Sub() is?

If you want to post the Sub() here (exact cut and paste) I can try adding it to a module here in Outlook and see if I can create a rule linked to it.  Just a thought...

---

»bp

Yes is a new sub.

 Dim objFSO As Object

Sub SaveAttachmentsBySubjectDateGB(NewEmail As MailItem)
    Dim NewAttachments As Outlook.Attachments
    Dim NewAttachment As Outlook.Attachment
    Dim SaveFolder As String
    Dim SavePath As String
   
    Dim BaseFolder As String
        
    ' Base folder for all attachments
    BaseFolder = "C:\"
    
    ' Get attachements to this email
    Set NewAttachments = NewEmail.Attachments
    
    ' If no attachments then we're done
    If NewAttachments.Count = 0 Then
        Set NewAttachments = Nothing
        Exit Sub
    End If
    
    ' Create folder if it doesn't exist
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    If Not objFSO.FolderExists(BaseFolder) Then
        MakeDir BaseFolder
    End If
    
    ' Process all attachments
    For Each NewAttachment In NewAttachments
        
        ' Add attachement file name to folder to get full path to save to
        SavePath = BaseFolder & "\" & NewFileName(NewAttachment.FileName)
        
        ' Only save if it doesn't already exist
        If Not objFSO.FileExists(SavePath) Then
            NewAttachment.SaveAsFile SavePath
        End If
    
    Next NewAttachment
    
    ' Clean up objects
    Set objFSO = Nothing
    Set NewAttachments = Nothing

End Sub

Sub MakeDir(strPath As String)
' Subroutine to create a folder as well as any needed parent folders

   Dim strAbsPath As String
   Dim strParent As String

   ' Get absolute path to folder to create
   strAbsPath = objFSO.GetAbsolutePathName(strPath)

   ' If it exists already we are done
   If objFSO.FolderExists(strAbsPath) Then
      Exit Sub
   End If

   ' Get the path for the parent of this folder
   strParent = objFSO.GetParentFolderName(strAbsPath)

   ' Stop when we get to the root
   If strParent <> "" Then
      ' If this parent folder doesn't exist create it (recursive to create any additional parents needed)
      If Not objFSO.FolderExists(strParent) Then
         MakeDir strParent
      End If
   End If

   ' Now create this folder
   objFSO.CreateFolder (strAbsPath)

End Sub

Function NewFileName(strOldFileName)
    ' existing name + "_21-10-11" (current day-1) => attachmentfile1_21-10-11.pdf where it is in YY-MM-DD format.
    NewFileName = objFSO.GetBaseName(strOldFileName) & "_" & TimeStamp(Now) & "." & objFSO.GetExtensionName(strOldFileName)

End Function

Function TimeStamp(ByVal dtmDateTime)
    Dim dtmYesterday

    dtmYesterday = dtmDateTime - 1

    ' YY-MM-DD format (of yesterdays date)
    TimeStamp = Right(Year(dtmYesterday), 2) & "-" & Right("0" & Month(dtmYesterday), 2) & "-" & Right("0" & Day(dtmYesterday), 2)
End Function

Select allOpen in new window

Strange, but not sure what to suggest...

At this point if you think we solved your original question maybe close this one, and open a new one specific to this new problem.  Get some other experts looking at it...

---

»bp

@Bill, the problem is the script doesn't run with the rule in error and I tried naming sub, delete the rule and create new rule from scratch again (basically did what the thread starter did - https://forums.slipstick.com/threads/93957-cannot-run-script-from-rule/) and also : "Run this rule now on messages already in inbox"
but nothing happens.

So how do I know the script actually work?

Okay, I see one obvious problem, and in testing your current script on my system I ran into the problem, so you likely are too.  You have the following line:

   BaseFolder = "C:\"

so are trying to store your incoming email attachments right in the root of the C: drive.  But this is a protected folder under recent / current versions of Windows, and is not allowed unless you are working in an elevated authority mode, which Outlook isn't.  As a result when the VBA code tries to save the extension file it gets an error, and ends the VBS code for that email at that point.  But no error message is actually displayed anyplace, that's because Outlook knows it is processing a rule and doesn't want to pop an messages from those.

So, change the Base Folder to something else, like perhaps:

   BaseFolder = "C:\Temp"

Also notice I removed the trailing backslash.  Since your code contains the following further down:

       SavePath = BaseFolder & "\" & NewFileName(NewAttachment.FileName)

that adds in the backslach between the BaseDir and the attachment file name.  So you don't want a trailing backslash on the BaseDir variable, otherwise you will end up with two backslashes in the path to the saved attachment.  I don't know off hand if that would cause a problem, different situations deal with double backslashes in file paths differently, but best to do it the proper way.

Below is an updated version of you script that worked correctly here.

Dim objFSO As Object

Sub SaveAttachmentsBySubjectDateGB(NewEmail As MailItem)
    Dim NewAttachments As Outlook.Attachments
    Dim NewAttachment As Outlook.Attachment
    Dim SaveFolder As String
    Dim SavePath As String
   
    Dim BaseFolder As String
        
    ' Base folder for all attachments
    BaseFolder = "C:\Temp"
    
    ' Get attachements to this email
    Set NewAttachments = NewEmail.Attachments
    
    ' If no attachments then we're done
    If NewAttachments.Count = 0 Then
        Set NewAttachments = Nothing
        Exit Sub
    End If
    
    ' Create folder if it doesn't exist
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    If Not objFSO.FolderExists(BaseFolder) Then
        MakeDir BaseFolder
    End If
    
    ' Process all attachments
    For Each NewAttachment In NewAttachments
        
        ' Add attachement file name to folder to get full path to save to
        SavePath = BaseFolder & "\" & NewFileName(NewAttachment.FileName)
        
        ' Only save if it doesn't already exist
        If Not objFSO.FileExists(SavePath) Then
            NewAttachment.SaveAsFile SavePath
        End If
    
    Next NewAttachment
    
    ' Clean up objects
    Set objFSO = Nothing
    Set NewAttachments = Nothing

End Sub

Sub MakeDir(strPath As String)
' Subroutine to create a folder as well as any needed parent folders

   Dim strAbsPath As String
   Dim strParent As String

   ' Get absolute path to folder to create
   strAbsPath = objFSO.GetAbsolutePathName(strPath)

   ' If it exists already we are done
   If objFSO.FolderExists(strAbsPath) Then
      Exit Sub
   End If

   ' Get the path for the parent of this folder
   strParent = objFSO.GetParentFolderName(strAbsPath)

   ' Stop when we get to the root
   If strParent <> "" Then
      ' If this parent folder doesn't exist create it (recursive to create any additional parents needed)
      If Not objFSO.FolderExists(strParent) Then
         MakeDir strParent
      End If
   End If

   ' Now create this folder
   objFSO.CreateFolder (strAbsPath)

End Sub

Function NewFileName(strOldFileName)
    ' existing name + "_21-10-11" (current day-1) => attachmentfile1_21-10-11.pdf where it is in YY-MM-DD format.
    NewFileName = objFSO.GetBaseName(strOldFileName) & "_" & TimeStamp(Now) & "." & objFSO.GetExtensionName(strOldFileName)

End Function

Function TimeStamp(ByVal dtmDateTime)
    Dim dtmYesterday

    dtmYesterday = dtmDateTime - 1

    ' YY-MM-DD format (of yesterdays date)
    TimeStamp = Right(Year(dtmYesterday), 2) & "-" & Right("0" & Month(dtmYesterday), 2) & "-" & Right("0" & Day(dtmYesterday), 2)
End Function

Select allOpen in new window

---

»bp

No that is not an issue since that is not the actual directory i use.

I stated "C:\" as I deleted the exact folder directory name.

My actual directory is like this where folder name= to the actual name.
"F:\Folder Name\Folder Name1\Folder Name 2

I tried to do create the rule from scratch and remove the "old" ones but still the same error: script doesn't exist or invalid.

Just for curiosity, can you open a Command Prompt window and run the following command.  Paste back the display please.

reg query HKCU\Software\Microsoft\Office\16.0\Outlook\Security /v EnableUnsafeClientMailRules

Select allOpen in new window

---

»bp

I'm not sure exactly where you are getting the error, can you follow the following process and tell me where you are getting an error and capture some screen shots when it happens?

1. In Outlook, open the VBA editor.
2. Create a new module.
3. Paste the code below into the Module.
4. Do "Debug", "Compile" and make sure no errors are found.
5. Open Manage Rules & Alerts for the desired email account.
6. Click New Rule.
7. Select "Apply rule on messages I receive" from the "Start from a blank rule" section.
8. Click "Next".
9. Click "Next" so that all incoming message will be processed.
10. Click "Yes" on the popup warning,
11. Select "run a script".
12. In the "Step 2" area click on the "run a script" link.
13. Select TextVBA from the list.
14. Click "Next".
15. Click "Next" to skip defining exceptions.
16. Give the rule a name.
17. Enable "Run this rule now on messages already in Inbox".
18. Make sure "Turn on this rule" is enabled.
19. Click "Finish".

At this point you should get a pop up message for each email in the Inbox (so do it on an account without many existing emails).

---

»bp

At the following point:

17. Enable "Run this rule now on messages already in Inbox".

and also when the message is being received in inbox

I also use an "old" module, and apply the above steps and change the information accordingly.
But the same error occur.

Any idea ?
The most frustrating thing is Outlook mail rules do not have the identification by attachment name, else i can make use of it and not use the script as another workaround.

Just for curiosity, can you open a Command Prompt window and run the following command.  Paste back the display please.

I never saw an answer to this question I had posted...

---

»bp

Sorry Bill, think i missed that out.
Here is the result:

Okay, that is what you want.

Ok thanks then why do I keep receiving error? Is there any other ways that I didn't try ?

@Bill, What if I have only 2 files:
1. "AB202P1"  
2. "AB202P2"

I tried to improvise but got an error.

I will try this in another computer with Outlook and see how it goes. Thanks.

When using another comp, outlook failed to start, and need to restart comp to get it started again.

Thereafter, there is no script error and neither did the files are saved in the folder. Basically nothing happens.
The rule is activated (with a tick besides)

As I think I may have mentioned in one of these threads earlier, the easiest way is to use the VBA debugger and single step through an invocation of the trigger where you expect it should have written something out.  You can watch the logic flow and also inspect variables to see what is truly happening.

Let me know if you are not familiar with the Debugger or need additional help.

---

»bp

Here is my test results following your suggestion action steps:

1. In Outlook, open the VBA editor.
2. Create a new module.
3. Paste the code below into the Module.
4. Do "Debug", "Compile" and make sure no errors are found.
5. Open Manage Rules & Alerts for the desired email account.
6. Click New Rule.
7. Select "Apply rule on messages I receive" from the "Start from a blank rule" section.
8. Click "Next".
9. Click "Next" so that all incoming message will be processed.
10. Click "Yes" on the popup warning,
11. Select "run a script".
12. In the "Step 2" area click on the "run a script" link.
13. Select TextVBA from the list.
14. Click "Next".
15. Click "Next" to skip defining exceptions.
16. Give the rule a name.
17. Enable "Run this rule now on messages already in Inbox".
18. Make sure "Turn on this rule" is enabled.
19. Click "Finish".

At Step 13, - what is TextVBA ? I just selected the script that you mentioned before in here
https://www.experts-exchange.com/questions/29233062/Outlook-script-to-save-a-copy-of-the-attachment-with-specific-criteria-in-a-specified-folder.html?notificationFollowed=283283489#a43398033 https://www.experts-exchange.com/questions/29233062/Outlook-script-to-save-a-copy-of-the-attachment-with-specific-criteria-in-a-specified-folder.html?notificationFollowed=283283489#a43398033





The above is the same as what i have done previously but strangely all newly created scripts have the same error.

>> At Step 13, - what is TextVBA ?
That should be a line in the screen that pops up when you click the 'a script' part in 'run a script' in the Rules Wizard window. The window would look something like this:

Can you post the contents of your 'Select Script' window after clicking 'run a script'?

This is the content of Select Script:

I've been off the site for a month or so while travelling, where do you stand on this, ever make any progress?

---

»bp

@Bill i have accepted your solution though i couldn't resolve the error. Perhaps is my outlook has issue but couldn't be resolved as it is weird the earlier scripts are running ok. I will pose question again if there is any further update. Thanks.

@Gerwin there is no reply from you after my reply. Anyhow this question is closed.