Macro to automatically save email attachments

Hi,
I found this script. Follow the below description
1. Start Outlook
2. Press ALT+F11 to go into VB editor
3. Rightclick Project1 and choose Insert > Module
4. Click Module1
5. Paste in this code below
6. Change the row Const BASE_PATH = "H:\\MailAttachments\\" to where you wanna save the attachments. Make sure you created the folder it points to.
7. Click Save button
8. Create a rule in Outlook that uses script (this script will now be available in the list)
 
hope this helps
/MadJax

Sub StripAttachments(Item As Outlook.MailItem)
 
On Error GoTo EarlyBath
 
Const BASE_PATH = "H:\\MailAttachments\\"
 
If Item.Class = olMail Then
    If Item.Attachments.Count > 0 Then
        Dim objAtt As Outlook.Attachments
        Set objAtt = Item.Attachments
        For Each objattach In objAtt
            Dim i, lngCounter As Long
            Dim strLogger, strFile, strLocalFileLink, strLocalPath, strUser, strFolder As String
 
            
            lngCounter = Item.Attachments.Count
            'Debug.Print lngcounter
            strLogger = "-------------------------------------------------------------------------------------------------"
                                    
            'organise folders by sender
            strFolder = BASE_PATH & Item.SenderName & "\\"
            
            If Dir(strFolder, vbDirectory) = "" Then
                MkDir (strFolder)
            End If
            
            'organise subfolder by received date
            strFolder = strFolder & Strings.Format(Item.ReceivedTime, "ddmmyyyy") & "\\"
            
            If Dir(strFolder, vbDirectory) = "" Then
                MkDir (strFolder)
            End If
            
            
            'create and display link to dest folder
            strLocalPath = "file://" & Replace(strFolder, " ", "%20")
            strLocalPath = Replace(strLocalPath, "\\", "\")
            strLogger = strLogger & vbCrLf & "Attachment Path: " & strLocalPath & vbCrLf
            strLogger = strLogger & vbCrLf & "The following attachments have been stripped from this message:"
            
            
            
            'move through the attachments, saving the file, deleting from msg body and inserting links
            For i = lngCounter To 1 Step -1
            
                strFile = objAtt.Item(i).FileName
                If Len(strFile) > 0 Then
                    Dim trimLen: trimLen = Len(strFile) - InStrRev(strFile, ".")
                    Dim time As String
                    time = Format(Now(), "hhmm")
                    strFile = strFolder & "\\" & time & "_" & strFile
                    objAtt.Item(i).SaveAsFile strFile
                    objAtt.Item(i).Delete
                    strLocalFileLink = Replace(strFile, "\\", "\")
                    strLocalFileLink = "file://" & Replace(strLocalFileLink, " ", "%20")
                
                    strLogger = strLogger & vbCrLf & vbCrLf & "Attachment " & lngCounter & ": " & strLocalFileLink
                Else
                End If
                    'strLogger = ""
SkipAtt:
            Next i
            
            strLogger = strLogger & vbCrLf & "-------------------------------------------------------------------------------------------------" & vbCrLf
            
            Item.Body = strLogger & Item.Body
            Item.Save
        Next
            Set objAtt = Nothing
        
    End If
End If
EarlyBath:
Exit Sub
End Sub

Select allOpen in new window

BlueDevilFan:

I tried you script but it doesn't seem to work. In fact, it doesn't even show in the run macro list. (But a test sub I entered does).

I created a new mod and pasted your sub into it.
Then I created a msg rule based on a subject line keyword (savetest)
set to run your script. I sent my self a msg with savetest in the subject and a small csv file attached but the attachment doesn't get saved.

Another thing I noticed is that when creating my rule, only your sub shows in the script list but not my test sub.  Any ideas?

Macroes which include parameters to be passed, i.e. starts off with "sub macroname (parameter as type)", will not show in the list of macros.  This is the type of macro you need when associating the script with a rule - so you can pass the mailitem being used, which is what you apparently want in this instance.

Have you enabled macros in your security settings in Outlook?  If you have not, then you will be able to create the rule, and associate the macro, but it won't run.

What did you change H:\\MailAttachments to?

Macros are enabled.
There is no  H:\\MailAttachments in BlueDevilFan's macro.
That one shows as "C:\" which I changed to "C:\emailtest".
Does it need the double back slash?

I changed the "C:\ " to C:\\
Now I get a error "Compile error: Wrong number of arguments or invalid property assignment.

The macro stops and the LCase is highlighted.

I just tried it as "C:\\emailtest\\" but still get the same error.

Madjax:
  I also tried your, which works but gives a popup box before being able to complete.
The box states:
  A program is trying to access e-mail addresses you have stored in Outlook.
Do you want to allow this?

Clicking the yes button will allow the macro to complete and the attachment to be saved. It also writes the info into the email about the attachment being stripped and saved.
I need this to be long term automatic and work fully unattended.
Anyone have any ideas on how to keep it from promptinfo for this permission?

"I tried you script but it doesn't seem to work. In fact, it doesn't even show in the run macro list. (But a test sub I entered does)."
That's to be expected.  The script is only desined to be run from a rule.  It wouldn't show up in the list of available macros when trying to run a macro via Tools > Macro > Macros.

"Another thing I noticed is that when creating my rule, only your sub shows in the script list but not my test sub."
That 's to be expected to.  Only macros declared to accept a parameter, i.e. Item As Outlook.MailItem, will appear in the list of available macros when selecting  amcro to run from a rule.

"but the attachment doesn't get saved."
First we need to run a test to see if the macro is failing to fire.  To do that, add this line of code between lines 7 and 8 of the original code:

    MsgBox "Rule fired"

Now, try your test again and let me know what happens.

Hi again afcnoc,
The message you get is due to a Microsoft security patch and can be disabled by 3rd party software. Most scripts in Outlook will make this message to come up. I use this script at work and it works good, but yes I had to install a software to disable the security message.

Try the Advanced Security for Outlook from MapiLab.
directlink> http://www.mapilab.com/files/security_outlook.zip

BlueDevilFan:
The script is running but I get an error on line 5 at the LCase statement
"Wrong number of arguments or invalid property assignment"
The comment above this line mentions changing the file name.
Do you mean the "csv" before the then statement?

Madjax:
  This is going to run on several computers throughout a large corporation.
I am pretty sure our IT dept will not be pleased with us adding any security anything to the Outlook client.
But I will ask them.

The error is my fault.  It's a typo.  Change line #3 to

If Right(LCase(olkFile.FileName),3) = "csv" Then

Select allOpen in new window

Tried it.
Got this error in the Watches window
Watch :   :         Right(LCase(olkFile.FileName, 3)) : <Wrong number of arguments or invalid property assignment> : Empty : Module1.SaveCSVToDisk

You left out the closing parentheses after olkFileName.

Oh, and you added it after the 3.

You are making the filename lowercase for purposes of comparison.
LCase(olkFile.Filename)

Then you are comparing just the last 3 characters of that to see if it is a csv file
Right(LCase(olkFile.FileName),3)